home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 January / PCWorld_2005-01_cd.bin / software / vyzkuste / office / office.exe / pcwAddHyperlink.BAS < prev    next >
Encoding:
BASIC Source File  |  2004-11-09  |  4.4 KB  |  125 lines
  1. Const OFN_ALLOWMULTISELECT   As Long = &H200
  2. Const OFN_CREATEPROMPT       As Long = &H2000
  3. Const OFN_EXPLORER           As Long = &H80000
  4. Const OFN_EXTENSIONDIFFERENT As Long = &H400
  5. Const OFN_FILEMUSTEXIST      As Long = &H1000
  6. Const OFN_HIDEREADONLY       As Long = &H4
  7. Const OFN_LONGNAMES          As Long = &H200000
  8. Const OFN_NOCHANGEDIR        As Long = &H8
  9. Const OFN_NODEREFERENCELINKS As Long = &H100000
  10. Const OFN_OVERWRITEPROMPT    As Long = &H2
  11. Const OFN_PATHMUSTEXIST      As Long = &H800
  12. Const OFN_READONLY           As Long = &H1
  13. Const MAX_PATH As Long = 260
  14. Const MAX_BUFFER As Long = 50 * MAX_PATH
  15. Const sBackSlash As String = "\"
  16. Const sPipe As String = "|"
  17.  
  18. Private Declare Function GetOpenFileName Lib "COMDLG32.DLL" Alias "GetOpenFileNameA" _
  19.   (pOpenfilename As OPENFILENAME) As Long
  20. Private Declare Function GetSaveFileName Lib "COMDLG32.DLL" Alias "GetSaveFileNameA" _
  21.   (pOpenfilename As OPENFILENAME) As Long
  22. Private Declare Function GetActiveWindow Lib "user32" () As Long
  23. Private Declare Function GetTempFileName _
  24.     Lib "kernel32" Alias "GetTempFileNameA" _
  25.    (ByVal lpszPath As String, _
  26.     ByVal lpPrefixString As String, _
  27.     ByVal wUnique As Long, _
  28.     ByVal lpTempFileName As String) As Long
  29.  
  30. Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  31.     Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
  32. Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
  33.     Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
  34. Private Declare Function DeleteFile Lib "kernel32" Alias _
  35.     "DeleteFileA" (ByVal lpFilename As String) As Long
  36. Private Declare Function MoveFile Lib "kernel32" Alias _
  37.     "MoveFileA" (ByVal lpExistingFileName As String, _
  38.     ByVal lpNewFileName As String) As Long
  39. Private Declare Function GetFullPathName Lib "kernel32.dll" Alias _
  40.   "GetFullPathNameA" (ByVal lpFilename As String, ByVal nBufferLength As Long, _
  41.   ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
  42. Private Type OPENFILENAME
  43.   lStructSize       As Long
  44.   hwndOwner         As Long
  45.   hInstance         As Long
  46.   lpstrFilter       As String
  47.   lpstrCustomFilter As String
  48.   nMaxCustFilter    As Long
  49.   nFilterIndex      As Long
  50.   lpstrFile         As String
  51.   nMaxFile          As Long
  52.   lpstrFileTitle    As String
  53.   nMaxFileTitle     As Long
  54.   lpstrInitialDir   As String
  55.   lpstrTitle        As String
  56.   Flags             As Long
  57.   nFileOffset       As Integer
  58.   nFileExtension    As Integer
  59.   lpstrDefExt       As String
  60.   lCustData         As Long
  61.   lpfnHook          As Long
  62.   lpTemplateName    As String  ' Can also be a Long.
  63.  
  64. End Type
  65.  
  66. Private Type BROWSEINFO
  67.     hOwner As Long
  68.     pidlRoot As Long
  69.     pszDisplayName As String
  70.     lpszTitle As String
  71.     ulFlags As Long
  72.     lpfn As Long
  73.     lParam As Long
  74.     iImage As Long
  75. End Type
  76.  
  77. Sub pcwAddHyperlink()
  78. Dim OFN As OPENFILENAME
  79. OFN.Flags = OFN.Flags Or OFN_EXPLORER Or OFN_LONGNAMES Or OFN_HIDEREADONL
  80. With OFN
  81.    .lStructSize = Len(OFN)
  82.    .nMaxFile = IIf(.Flags And OFN_ALLOWMULTISELECT, MAX_BUFFER + 1, MAX_PATH + 1)
  83.    .nMaxFileTitle = MAX_PATH + 1
  84.    .lpstrFile = .lpstrFile & String$(.nMaxFile - 1 - Len(.lpstrFile), 0)
  85.    .lpstrFilter = "VÜechny soubory (*.*)" & Chr(0) & "*.*" & Chr(0) & _
  86.     "Texty, Tabulky" & Chr(0) & "*.doc;*.rtf;*.txt;*.htm;*.html;*.xls;*.ppt;*.url" & Chr(0) & _
  87.     "Obrßzky, Hudba" & Chr(0) & "*.jpg;*.jpeg;*.bmp;*.tif;*.tiff;*.pcx;*.gif;*.wav;*.mp3;*.wma;*.ogg" & Chr(0) & _
  88.     "Archφvy, Programy" & Chr(0) & "*.zip;*.rar;*.exe;*.dll;*.bat;*.hta;*.vbs;*.js;*.ocx" & Chr(0)
  89.     ret = GetOpenFileName(OFN)
  90.     If ret <> 0 Then
  91.       datei = .lpstrFile
  92.     Else
  93.       Exit Sub
  94.     End If
  95. End With
  96.  
  97. Do
  98.     t = t + 1
  99.     temp = Mid(datei, t)
  100. Loop While InStr(temp, "\")
  101. dateiname = Mid(datei, t)
  102.  
  103. wordfilepfad = ActiveDocument.Path
  104. wordfilename = ActiveDocument.Name
  105.  
  106. If wordfilepfad = "" Then
  107.     MsgBox "P°ed vlo₧enφm odkazu nejprve dokument ulo₧te!"
  108.     Exit Sub
  109. End If
  110. temp = InStr(wordfilename, ".")
  111. ohneExtension = Left(wordfilename, temp - 1)
  112. ziel = wordfilepfad & "\" & ohneExtension & "_" & dateiname
  113. If UCase(datei) <> UCase(ziel) Then
  114.     FileCopy datei, ziel
  115. End If
  116. Selection.TypeParagraph
  117. ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
  118.         ohneExtension & "_" & dateiname, SubAddress:=""
  119. Selection.TypeParagraph
  120. End Sub
  121.  
  122.  
  123.  
  124.  
  125.