|
|
Postada em 29/08/2008 02:02 hs
Ae pessoal, resolvi postar estas dicas que deve ser de interesse de muitos desenvolvedores, aqui contém:
* Escolher Ícone do Painel de Controle do Windows
* Procurar Pasta
* Janela Desligar o Computador do Windows (Iniciar -> Desligar)
* Janela Executar do Windows (Iniciar -> Executar)
* Reiniciar o Sistema (É aquela caixa de diálogo que pergunta se você deseja reiniciar o computador para que as novas configurações tenham efeito, ideal para quem desenvolve programas de instalação)
'********************************************************
Option Explicit
Const EWX_LOGOFF = 0
Const EWX_SHUTDOWN = 1
Const EWX_REBOOT = 2
Const EWX_FORCE = 4
Const EWX_POWEROFF = 8
Const shrdNoMRUString = &H2
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
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 Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function SHRunDialog Lib "shell32" Alias "#61" (ByVal hOwner As Long, ByVal Unknown1 As Long, ByVal Unknown2 As Long, ByVal szTitle As String, ByVal szPrompt As String, ByVal uFlags As Long) As Long
Private Declare Function SHRestartSystemMB Lib "shell32" Alias "#59" (ByVal hOwner As Long, ByVal sExtraPrompt As String, ByVal uFlags As Long) As Long
Private Declare Function SHShutDownDialog Lib "shell32" Alias "#60" (ByVal YourGuess As Long) As Long
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 SHChangeIconDialogA Lib "shell32" Alias "#62" (ByVal hOwner As Long, ByVal szFilename As String, ByVal Reserved As Long, lpIconIndex As Long) As Long
Private Declare Function SHChangeIconDialogW Lib "shell32" Alias "#62" (ByVal hOwner As Long, ByVal szFilename As Long, ByVal Reserved As Long, lpIconIndex As Long) As Long
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260
Private Const VER_PLATFORM_WIN32_NT = 2
Private Sub ChooseIcon()
'Exibe Janela Escolher Ícone do Windows
chooseIconB "shell32.dll", 0
End Sub
Private Sub BrowseForFolder()
'Exibe a Janela Procurar Pasta do Windows
Dim iNull As Integer, lpIDList As Long, lResult As Long
Dim sPath As String, udtBI As BrowseInfo
With udtBI
.hwndOwner = Me.hWnd
.lpszTitle = lstrcat("C:", "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
SHGetPathFromIDList lpIDList, sPath
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
MsgBox sPath
End Sub
Private Sub ShutDownDialog()
'Exibe Janela Desligar o Computador do Windows
SHShutDownDialog 0
End Sub
Private Sub RunDialog()
'Exibe Janela executar do Windows
Dim sTitle As String, sPrompt As String
sTitle = "Iniciar um Programa"
sPrompt = "Informe o nome do aplicativo."
If IsWinNT Then
SHRunDialog Me.hWnd, 0, 0, StrConv(sTitle, vbUnicode), StrConv(sPrompt, vbUnicode), 0
Else
SHRunDialog Me.hWnd, 0, 0, sTitle, sPrompt, 0
End If
End Sub
Private Sub RestartSystem()
'Exibe aquela Janela que pergunta se você quer reiniciar o pc
'para que as novas configurações tenham efeito
SHRestartSystemMB Me.hWnd, vbNullString, EWX_FORCE
End Sub
'Detecta se o aplicativo está executando do Windows NT
Public Function IsWinNT() As Boolean
Dim myOS As OSVERSIONINFO
myOS.dwOSVersionInfoSize = Len(myOS)
GetVersionEx myOS
IsWinNT = (myOS.dwPlatformId = VER_PLATFORM_WIN32_NT)
End Function
Private Function chooseIconB(ByRef strFile As String, ByRef lngIconNum As Long) As Boolean
Dim str1 As String * 260
Dim lng1 As Long
Dim lngResult As Long
str1 = strFile & vbNullChar
If IsWinNT Then
lngResult = SHChangeIconDialogW(Me.hWnd, StrPtr(str1), lng1, lngIconNum)
Else
lngResult = SHChangeIconDialogA(Me.hWnd, str1, lng1, lngIconNum)
End If
chooseIconB = (lngResult <> 0)
If chooseIconB Then
strFile = Left$(str1, InStr(1, str1, vbNullChar, vbBinaryCompare) - 1)
End If
End Function
Excelent Code
|
|
|
|
|
|
|
|
Postada em 29/08/2008 02:13 hs
* Além das Caixas de Diálogos Abrir e Salvar convencional o Windows possui também essas outras duas caixas de diálogo:
'***********************************************************
Option Explicit
Private Const OFN_EXPLORER = &H80000
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function GetOpenFileNamePreview Lib "msvfw32.dll" (ByRef lpofn As OPENFILENAME) As Long
Private Declare Function GetSaveFileNamePreview Lib "msvfw32.dll" Alias "GetSaveFileNamePreviewA" (ByRef lpofn As OPENFILENAME) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Sub OpenFileNamePreview()
'Outra Caixa de Diálogo Abrir Arquivo que o Windows possui
Dim OFN As OPENFILENAME, Ret As Long
With OFN
.lStructSize = Len(OFN)
.hInstance = App.hInstance
.hwndOwner = Me.hWnd
.lpstrTitle = "Open a file"
.lpstrFilter = "AVI file (*.avi)" + Chr$(0) + "*.avi" + Chr$(0) + "All files (*.*)" + Chr$(0) + "*.*"
.lpstrFile = String(255, 0)
.nMaxFile = 255
.flags = OFN_EXPLORER
End With
Ret = GetOpenFileNamePreview(OFN)
If Ret <> 0 Then
CloseHandle Ret
MsgBox Left$(OFN.lpstrFile, InStr(1, OFN.lpstrFile, Chr$(0)) - 1)
End If
End Sub
Private Sub SaveFileNamePreview()
'Outra Caixa de Diálogo Salvar arquivo que o Windows possui
Dim OFN As OPENFILENAME, Ret As Long
OFN.lpstrTitle = "Salvar um arquivo"
Ret = GetSaveFileNamePreview(OFN)
If Ret <> 0 Then
CloseHandle Ret
MsgBox Left$(OFN.lpstrFile, InStr(1, OFN.lpstrFile, Chr$(0)) - 1)
End If
End Sub
Excelent Code
|
|
|
|
|
|
Postada em 29/08/2008 02:42 hs
Há também outras formas de abrir janelas do sistema executando uma linha de comando
através do código Shell ou pela API Winexec, porém não possui valor de retorno:
'Abre o Painel de Controle
rundll32.exe shell32.dll Control_RunDLL
'Abre a Janela Propriedades de Vídeo do Sistema na Guia "Temas"
rundll32.exe shell32.dll Control_RunDLL desk.cpl,0,-1
'Abre a Janela Propriedades de Vídeo do Sistema na Guia "Área de Trabalho"
rundll32.exe shell32.dll Control_RunDLL desk.cpl,0,0
'Abre a Janela Propriedades de Vídeo do Sistema na Guia "Proteção de tela"
rundll32.exe shell32.dll Control_RunDLL desk.cpl,0,1
'Abre a Janela Propriedades de Vídeo do Sistema na Guia "Aparência"
rundll32.exe shell32.dll Control_RunDLL desk.cpl,0,2
'Abre a Janela Propriedades de Vídeo do Sistema na Guia "Configurações"
rundll32.exe shell32.dll Control_RunDLL desk.cpl,0,3
Outros arquivos CPL:
access.clp Opções de Acessibilidade
appwiz.cpl Adicionar ou Remover Programas
bdeadmin.cpl BDE Administrator
bthprops.cpl
desck.cpl Propriedades de Vídeo
firewall.cpl Firewall do Windows
hdwwiz.cpl Assistente para Adicionar novo Hardware
inetcpl.cpl Propriedades de Internet
intl.cpl Opções regionais e de Idioma
irprops.cpl
joy.cpl Controladores de Jogo
main.cpl Propriedades de Mouse
mmsys.cpl Propriedades de Sons e dispositivos de áudio
ncpa.cpl Conexões de rede
netsetup.cpl Assistente de configuração de rede
nusrmgr.cpl Contas de usuário
nwc.cpl
odbccp32.cpl Administrador de fonte de dados ODBC
powercfg.cpl Propriedades de Opções de energia
sysdm.cpl Propriedades do Sistema
telephon.cpl
timedate.cpl Propriedades de Data e Hora
wscui.cpl Central de Segurança do Windows
wuaucpl.cpl Atualizações automáticas
Excelent Code
|
|
|
|
|
|
Postada em 29/08/2008 02:56 hs
* Paleta de Cores padrão do Windows
'*********************************************************
Option Explicit
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Dim OFName As OPENFILENAME
Dim CustomColors() As Byte
Private Function ShowColor() As Long
Dim cc As CHOOSECOLOR
Dim Custcolor(16) As Long
Dim lReturn As Long
cc.lStructSize = Len(cc)
cc.hwndOwner = Me.hWnd
cc.hInstance = App.hInstance
cc.lpCustColors = StrConv(CustomColors, vbUnicode)
cc.flags = 0
If CHOOSECOLOR(cc) <> 0 Then
ShowColor = cc.rgbResult
CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
Else
ShowColor = -1
End If
End Function
Excelent Code
|
|
|
|
|
|
Postada em 29/08/2008 03:07 hs
'Caixa de diálogo Imprimir
'************************************************************
Option Explicit
Const CCHDEVICENAME = 32
Const CCHFORMNAME = 32
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
Const DM_DUPLEX = &H1000&
Const DM_ORIENTATION = &H1&
Const PD_PRINTSETUP = &H40
Const PD_DISABLEPRINTTOFILE = &H80000
Private Type PRINTDLG_TYPE
lStructSize As Long
hwndOwner As Long
hDevMode As Long
hDevNames As Long
hDC As Long
flags As Long
nFromPage As Integer
nToPage As Integer
nMinPage As Integer
nMaxPage As Integer
nCopies As Integer
hInstance As Long
lCustData As Long
lpfnPrintHook As Long
lpfnSetupHook As Long
lpPrintTemplateName As String
lpSetupTemplateName As String
hPrintTemplate As Long
hSetupTemplate As Long
End Type
Private Type DEVNAMES_TYPE
wDriverOffset As Integer
wDeviceOffset As Integer
wOutputOffset As Integer
wDefault As Integer
extra As String * 100
End Type
Private Type DEVMODE_TYPE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Private Declare Function PrintDialog Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLG_TYPE) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Sub ShowPrinter(frmOwner As Form, Optional PrintFlags As Long)
Dim PrintDlg As PRINTDLG_TYPE
Dim DevMode As DEVMODE_TYPE
Dim DevName As DEVNAMES_TYPE
Dim lpDevMode As Long, lpDevName As Long
Dim bReturn As Integer
Dim objPrinter As Printer, NewPrinterName As String
PrintDlg.lStructSize = Len(PrintDlg)
PrintDlg.hwndOwner = frmOwner.hWnd
PrintDlg.flags = PrintFlags
On Error Resume Next
DevMode.dmDeviceName = Printer.DeviceName
DevMode.dmSize = Len(DevMode)
DevMode.dmFields = DM_ORIENTATION Or DM_DUPLEX
DevMode.dmPaperWidth = Printer.Width
DevMode.dmOrientation = Printer.Orientation
DevMode.dmPaperSize = Printer.PaperSize
DevMode.dmDuplex = Printer.Duplex
On Error GoTo 0
PrintDlg.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevMode))
lpDevMode = GlobalLock(PrintDlg.hDevMode)
If lpDevMode > 0 Then
CopyMemory ByVal lpDevMode, DevMode, Len(DevMode)
bReturn = GlobalUnlock(PrintDlg.hDevMode)
End If
On Local Error Resume Next
With DevName
.wDriverOffset = 8
.wDeviceOffset = .wDriverOffset + 1 + Len(Printer.DriverName)
.wOutputOffset = .wDeviceOffset + 1 + Len(Printer.Port)
.wDefault = 0
End With
With Printer
DevName.extra = .DriverName & Chr(0) & .DeviceName & Chr(0) & .Port & Chr(0)
End With
On Local Error GoTo 0
PrintDlg.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevName))
lpDevName = GlobalLock(PrintDlg.hDevNames)
If lpDevName > 0 Then
CopyMemory ByVal lpDevName, DevName, Len(DevName)
bReturn = GlobalUnlock(lpDevName)
End If
If PrintDialog(PrintDlg) <> 0 Then
lpDevName = GlobalLock(PrintDlg.hDevNames)
CopyMemory DevName, ByVal lpDevName, 45
bReturn = GlobalUnlock(lpDevName)
GlobalFree PrintDlg.hDevNames
lpDevMode = GlobalLock(PrintDlg.hDevMode)
CopyMemory DevMode, ByVal lpDevMode, Len(DevMode)
bReturn = GlobalUnlock(PrintDlg.hDevMode)
GlobalFree PrintDlg.hDevMode
NewPrinterName = UCase$(Left(DevMode.dmDeviceName, InStr(DevMode.dmDeviceName, Chr$(0)) - 1))
If Printer.DeviceName <> NewPrinterName Then
For Each objPrinter In Printers
If UCase$(objPrinter.DeviceName) = NewPrinterName Then
Set Printer = objPrinter
End If
Next
End If
On Error Resume Next
Printer.Copies = DevMode.dmCopies
Printer.Duplex = DevMode.dmDuplex
Printer.Orientation = DevMode.dmOrientation
Printer.PaperSize = DevMode.dmPaperSize
Printer.PrintQuality = DevMode.dmPrintQuality
Printer.ColorMode = DevMode.dmColor
Printer.PaperBin = DevMode.dmDefaultSource
On Error GoTo 0
End If
End Sub
Excelent Code
|
|
|
|
|
|
Postada em 29/08/2008 03:18 hs
* Caixa de Diálogo Escolher Fonte do Sistema, melhor que a do OCX do VB
*****************************************************************
Option Explicit
Const FW_NORMAL = 400
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const FF_ROMAN = 16
Const CF_PRINTERFONTS = &H2
Const CF_SCREENFONTS = &H1
Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const CF_LIMITSIZE = &H2000&
Const REGULAR_FONTTYPE = &H400
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 31
End Type
Private Type CHOOSEFONT
lStructSize As Long
hwndOwner As Long
hDC As Long
lpLogFont As Long
iPointSize As Long
flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
MISSING_ALIGNMENT As Integer
nSizeMin As Long
nSizeMax As Long
End Type
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Function ShowFont() As String
Dim cf As CHOOSEFONT, lfont As LOGFONT, hMem As Long, pMem As Long
Dim fontname As String, retval As Long
On Local Error Resume Next
lfont.lfHeight = 0
lfont.lfWidth = 0
lfont.lfEscapement = 0
lfont.lfOrientation = 0
lfont.lfWeight = FW_NORMAL
lfont.lfCharSet = DEFAULT_CHARSET
lfont.lfOutPrecision = OUT_DEFAULT_PRECIS
lfont.lfClipPrecision = CLIP_DEFAULT_PRECIS
lfont.lfQuality = DEFAULT_QUALITY
lfont.lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN
lfont.lfFaceName = "Times New Roman" & vbNullChar
hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
pMem = GlobalLock(hMem)
CopyMemory ByVal pMem, lfont, Len(lfont)
cf.lStructSize = Len(cf)
cf.hwndOwner = Form1.hWnd
cf.hDC = Printer.hDC
cf.lpLogFont = pMem
cf.iPointSize = 120
cf.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
cf.rgbColors = RGB(0, 0, 0)
cf.nFontType = REGULAR_FONTTYPE
cf.nSizeMin = 10
cf.nSizeMax = 72
On Error GoTo 0
retval = CHOOSEFONT(cf)
If retval <> 0 Then
CopyMemory lfont, ByVal pMem, Len(lfont)
ShowFont = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
End If
retval = GlobalUnlock(hMem)
retval = GlobalFree(hMem)
End Function
Excelent Code
|
|
|
|
|
