home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / Multiple_D2178123292010.psc / Functions.bas < prev    next >
BASIC Source File  |  2009-06-06  |  9KB  |  271 lines
  1. Attribute VB_Name = "Functions"
  2. Option Explicit
  3.  
  4. '=============Globals========================
  5. Public UserPath As String
  6. Public Const MyPath = "\VirtualDesktop"
  7. Public Const MySystem = "\Layout.ini"
  8. '============================================
  9. Private Const MAX_PATH As Long = 260
  10. Private Const INVALID_HANDLE_VALUE As Long = -1
  11. '============================================
  12. Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
  13. Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
  14. '============================================
  15. Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
  16.     (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
  17. Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
  18.     (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
  19. Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
  20. 'dwFlags
  21. Private Const CSIDL_FLAG_PER_USER_INIT = &H800
  22. Private Const CSIDL_FLAG_NO_ALIAS = &H1000
  23. Private Const CSIDL_FLAG_DONT_VERIFY = &H4000
  24. Private Const CSIDL_FLAG_CREATE = &H8000
  25. Private Const CSIDL_FLAG_MASK = &HFF00
  26. Private Const SHGFP_TYPE_CURRENT = &H0 'current value for user, verify it exists
  27. Private Const SHGFP_TYPE_DEFAULT = &H1
  28. '============================================
  29. Private Type FILETIME
  30.     dwLowDateTime As Long
  31.     dwHighDateTime As Long
  32. End Type
  33.  
  34. Private Type WIN32_FIND_DATA
  35.     dwFileAttributes As Long
  36.     ftCreationTime As FILETIME
  37.     ftLastAccessTime As FILETIME
  38.     ftLastWriteTime As FILETIME
  39.     nFileSizeHigh As Long
  40.     nFileSizeLow As Long
  41.     dwReserved0 As Long
  42.     dwReserved1 As Long
  43.     cFileName As String * MAX_PATH
  44.     cAlternateFileName As String * 14
  45. End Type
  46. '=======Launch Associated File API===========
  47. Declare Function ShellExecute _
  48.     Lib "shell32.dll" Alias "ShellExecuteA" ( _
  49.     ByVal hWnd As Long, _
  50.     ByVal lpOperation As String, _
  51.     ByVal lpFile As String, _
  52.     ByVal lpParameters As String, _
  53.     ByVal lpDirectory As String, _
  54.     ByVal nShowCmd As Long) As Long
  55.  
  56. '============ShellFolders API================
  57. Declare Function SHGetFolderPath _
  58.    Lib "shfolder.dll" Alias "SHGetFolderPathA" ( _
  59.    ByVal hwndOwner As Long, _
  60.    ByVal nFolder As Long, _
  61.    ByVal hToken As Long, _
  62.    ByVal dwReserved As Long, _
  63.    ByVal lpszPath As String) As Long
  64. '-------ShellFolders API Constants ----------
  65. Public Enum SF
  66.     CSIDL_MYDOCUMENTS = &H5
  67.     CSIDL_MYMUSIC = &HD
  68.     CSIDL_MYVIDEO = &HE
  69.     CSIDL_MYPICTURES = &H27
  70.     CSIDL_LOCAL_APPDATA = &H1C
  71.     CSIDL_DOCANDSET = &H28
  72.     
  73.     CSIDL_COMMON_DOCUMENTS = &H2E
  74.     CSIDL_COMMON_MUSIC = &H35
  75.     CSIDL_COMMON_VIDEO = &H37
  76.     CSIDL_COMMON_PICTURES = &H36
  77.     '-------------------------------------------
  78.     CSIDL_DESKTOP = &H0
  79.     CSIDL_INTERNET = &H1
  80.     CSIDL_PROGRAMS = &H2
  81.     CSIDL_CONTROLS = &H3
  82.     CSIDL_PRINTERS = &H4
  83.     CSIDL_FAVORITES = &H6
  84.     CSIDL_STARTUP = &H7
  85.     CSIDL_RECENT = &H8
  86.     CSIDL_SENDTO = &H9
  87.     CSIDL_BITBUCKET = &HA
  88.     CSIDL_STARTMENU = &HB
  89.     CSIDL_DESKTOPDIRECTORY = &H10
  90.     CSIDL_DRIVES = &H11
  91.     CSIDL_NETWORK = &H12
  92.     CSIDL_NETHOOD = &H13
  93.     CSIDL_FONTS = &H14
  94.     CSIDL_TEMPLATES = &H15
  95.     
  96.     CSIDL_COMMON_OEM_LINKS = &H3A
  97.     CSIDL_COMMON_TEMPLATES = &H2D
  98.     CSIDL_COMMON_ADMINTOOLS = &H2F
  99.     CSIDL_COMMON_FAVORITES = &H1F
  100.     CSIDL_COMMON_ALTSTARTUP = &H1E
  101.     CSIDL_COMMON_STARTMENU = &H16
  102.     CSIDL_COMMON_PROGRAMS = &H17
  103.     CSIDL_COMMON_STARTUP = &H18
  104.     CSIDL_COMMON_DESKTOPDIRECTORY = &H19
  105.     
  106.     CSIDL_APPDATA = &H1A
  107.     CSIDL_PRINTHOOD = &H1B
  108.     CSIDL_ALTSTARTUP = &H1D
  109.     CSIDL_INTERNET_CACHE = &H20
  110.     CSIDL_COOKIES = &H21
  111.     CSIDL_HISTORY = &H22
  112.     CSIDL_COMMON_APPDATA = &H23
  113.     CSIDL_WINDOWS = &H24
  114.     CSIDL_SYSTEM = &H25
  115.     CSIDL_PROGRAM_FILES = &H26
  116.     
  117.     CSIDL_SYSTEMX86 = &H29
  118.     CSIDL_PROGRAM_FILESX86 = &H2A
  119.     CSIDL_PROGRAM_FILES_COMMON = &H2B
  120.     CSIDL_PROGRAM_FILES_COMMONX86 = &H2C
  121.     CSIDL_ADMINTOOLS = &H30
  122.     CSIDL_CONNECTIONS = &H31
  123.     CSIDL_RESOURCES = &H38
  124.     CSIDL_RESOURCES_LOCALIZED = &H39
  125.     CSIDL_CDBURN_AREA = &H3B
  126.     CSIDL_COMPUTERSNEARME = &H3D
  127. End Enum
  128. '===============ShellFileOperations================
  129. Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (ByRef lpFileOp As SHFILEOPSTRUCT) As Long
  130. Private Type SHFILEOPSTRUCT
  131.     hWnd As Long
  132.     wFunc As Long
  133.     pFrom As String
  134.     pTo As String
  135.     fFlags As Integer
  136.     fAborted As Long
  137.     hNameMaps As Long
  138.     sProgress As String
  139. End Type
  140. '================GetIconFromFile================
  141. Private Type TypeIcon
  142.     cbSize As Long
  143.     picType As PictureTypeConstants
  144.     hIcon As Long
  145. End Type
  146.  
  147. Private Type CLSID
  148.     id(16) As Byte
  149. End Type
  150.  
  151. Private Type SHFILEINFO
  152.     hIcon As Long
  153.     iIcon As Long
  154.     dwAttributes As Long
  155.     szDisplayName As String * MAX_PATH
  156.     szTypeName As String * 80
  157. End Type
  158. Private SIconInfo As SHFILEINFO
  159. Private Const SHGFI_ICON = &H100
  160.  
  161. Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (pDicDesc As TypeIcon, riid As CLSID, ByVal fown As Long, lpUnk As Object) As Long
  162. Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
  163.  
  164. Public Function ExecuteShellCmd(Handle As Long, mOp As String, mFile As String, mParm As String, mDir As String, mCmd As Long) As Long
  165. ExecuteShellCmd = ShellExecute(Handle, mOp, mFile, mParm, mDir, mCmd)
  166. End Function
  167.  
  168. Public Function GetShellFolderPath(hWind As Long, SpcFolder As Long) As String
  169. 'Part of ShellFolders API
  170. Dim ShellBuff As String
  171. Dim dwFlags As Long
  172. Dim uType As Long
  173. ShellBuff = Space(260)
  174. dwFlags = CSIDL_FLAG_PER_USER_INIT
  175. uType = SHGFP_TYPE_CURRENT
  176.  
  177. If SHGetFolderPath(hWind, SpcFolder Or dwFlags, -1, uType, ShellBuff) = 0 Then
  178.     GetShellFolderPath = Left$(ShellBuff, lstrlenW(StrPtr(ShellBuff)))
  179. Else
  180.     GetShellFolderPath = "ERR"
  181. End If
  182.  
  183. End Function
  184.  
  185. Public Function FreezeWindow(Handle As Long) As Long
  186. LockWindowUpdate Handle
  187. End Function
  188. Public Function GetBase(Path As String) As String
  189. Dim S0 As Long, S1 As Long
  190. S0 = InStrRev(Path, ".", Len(Path))
  191. If S0 = 0 Then S0 = Len(Path) Else S0 = S0 - 1
  192. S1 = InStrRev(Path, "\", Len(Path))
  193. GetBase = Mid(Path, S1 + 1, S0 - S1)
  194. End Function
  195. Private Function TrimNull(sFileName As String) As String
  196.     Dim I As Long
  197.     I = InStr(1, sFileName, vbNullChar)
  198.     If I = 0 Then
  199.         TrimNull = sFileName
  200.     Else
  201.         TrimNull = Left$(sFileName, I - 1)
  202.     End If
  203. End Function
  204. Public Function GetFiles(Mfiles As String) As String
  205. Dim sBuff As String
  206. Dim iSearchHandle As Long
  207. Dim pBuf As WIN32_FIND_DATA
  208. Dim Tfile As String
  209.  
  210. sBuff = vbNullString
  211. iSearchHandle = FindFirstFile(Mfiles, pBuf)
  212. If iSearchHandle <> INVALID_HANDLE_VALUE Then
  213.     Do While FindNextFile(iSearchHandle, pBuf)
  214.         Tfile = TrimNull(pBuf.cFileName)
  215.         If Tfile <> "." And Tfile <> ".." Then
  216.             sBuff = sBuff & Tfile & Chr(0)
  217.         End If
  218.     Loop
  219.     Call FindClose(iSearchHandle)
  220.     GetFiles = sBuff
  221. End If
  222. End Function
  223. Public Sub CopyFiles(hWind As Long, sSource As String, sTarget As String)
  224.  
  225. Dim SHFO As SHFILEOPSTRUCT
  226. Dim Ret As Long
  227. Const FOF_SILENT As Long = &H4
  228. Const FO_COPY As Long = &H2
  229.  
  230. SHFO.hWnd = hWind
  231. SHFO.fFlags = FOF_SILENT
  232. SHFO.pFrom = sSource
  233. SHFO.pTo = sTarget
  234. SHFO.wFunc = FO_COPY
  235. Ret = SHFileOperation(SHFO)
  236. End Sub
  237. 'GetIconFromFile Private Function
  238. 'Convert an icon handle into an IPictureDisp.
  239. Private Function IconToPicture(hIcon As Long) As IPictureDisp
  240. Dim cls_id As CLSID
  241. Dim hRes As Long
  242. Dim new_icon As TypeIcon
  243. Dim lpUnk As IUnknown
  244.  
  245. With new_icon
  246.     .cbSize = Len(new_icon)
  247.     .picType = vbPicTypeIcon
  248.     .hIcon = hIcon
  249. End With
  250. With cls_id
  251.     .id(8) = &HC0
  252.     .id(15) = &H46
  253. End With
  254. hRes = OleCreatePictureIndirect(new_icon, cls_id, 1, lpUnk)
  255. If hRes = 0 Then Set IconToPicture = lpUnk
  256. End Function
  257. 'GetIconFromFile Public Function
  258. Public Function GetIcon(FileName As String, icon_size As Long) As IPictureDisp
  259. 'Large Icon=0,Small Icon=1
  260. Dim Index As Integer
  261. Dim hIcon As Long
  262. Dim item_num As Long
  263. Dim icon_pic As IPictureDisp
  264. Dim sh_info As SHFILEINFO
  265.  
  266. SHGetFileInfo FileName, 0, sh_info, Len(sh_info), SHGFI_ICON + icon_size
  267. hIcon = sh_info.hIcon
  268. Set icon_pic = IconToPicture(hIcon)
  269. Set GetIcon = icon_pic
  270. End Function
  271.