- Katılım
- 31 Ocak 2006
- Mesajlar
- 14
süper olmuş emeği olanlara saygılar...
-
DİKKAT DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Kapanırken gizli e-mail gönderilmesi
- Konbuyu başlatan akd
- Başlangıç tarihi
Dim iMsg As CDO.Message
Dim iConf As CDO.Configuration
Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = "smtp.gmail.com"
.Item(cdoSendUserName) = "akd1961@gmail.com"
.Item(cdoSendPassword) = "123456"
.Item(cdoSMTPServerPort) = 25
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "akd1961@hotmail.com"
.From = """akd1961"" <akd1961@hotmail.com>"
.Subject = "This is a test"
.TextBody = "Hi there"
'.AddAttachment "C:/" & WBname
' You can add any file you want with
'.AddAttachment "C:/Test.txt"
.Send
End With
Kodu yukarıdaki gibi yaptım, ama ekteki hatayı alıyorum.
Dim iConf As CDO.Configuration
Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = "smtp.gmail.com"
.Item(cdoSendUserName) = "akd1961@gmail.com"
.Item(cdoSendPassword) = "123456"
.Item(cdoSMTPServerPort) = 25
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "akd1961@hotmail.com"
.From = """akd1961"" <akd1961@hotmail.com>"
.Subject = "This is a test"
.TextBody = "Hi there"
'.AddAttachment "C:/" & WBname
' You can add any file you want with
'.AddAttachment "C:/Test.txt"
.Send
End With
Kodu yukarıdaki gibi yaptım, ama ekteki hatayı alıyorum.
- Katılım
- 26 Eylül 2007
- Mesajlar
- 9,421
- Excel Vers. ve Dili
- excel 2010
merhaba
dosyayı ve önceki 43 mesajları okumadım ama iyi bir virüs programı olan bilgisayarda bu kodlar sessiz sakin arka planda çalışır mı? virüs programı devreye girip engel olmuyor mu? en azından uyarmıyor mu?
dosyayı ve önceki 43 mesajları okumadım ama iyi bir virüs programı olan bilgisayarda bu kodlar sessiz sakin arka planda çalışır mı? virüs programı devreye girip engel olmuyor mu? en azından uyarmıyor mu?
- Katılım
- 7 Ocak 2005
- Mesajlar
- 236
- Excel Vers. ve Dili
- Office Excel 2003 Tr/İng.
- Altın Üyelik Bitiş Tarihi
- 03.01.2019
Sayın akd gmail için hesanınızı gmailde ayarlarda pop yönlendirmesi yapmanız gerekiyor bunu yapmış mıydınız acaba?
beab05
Özel Üye
- Katılım
- 19 Mart 2007
- Mesajlar
- 1,418
- Excel Vers. ve Dili
- Office 2013
Nod32, win2003 server kullanıyorum hiçbir uyarı almıyorum, acı ama gerçek 
Gmail için pop yönlendirmesine gerek yok ama from kısmı gmail olmalı..
Gmail için şimdi denedim gayet güzel oluyor..
Gmail için pop yönlendirmesine gerek yok ama from kısmı gmail olmalı..Gmail için şimdi denedim gayet güzel oluyor..
Kod:
Dim objCDOMail As Object
Set objCDOMail = CreateObject("CDO.Message")
objCDOMail.To = "xxxxxx@hotmail.com"
objCDOMail.From = "yyyyy@gmail.com"
'objCDOMail.CC = "xxxx@hotmail.com"
objCDOMail.Subject = "gmail deneme"
'objCDOMail.Addattachment "C:\kaynak.txt"
objCDOMail.TextBody = "gmail denemesi"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "kullanıcıadı"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "şifre"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objCDOMail.Configuration.Fields.Update
objCDOMail.Send
Set objCDOMail = NothingSet objCDOMail = CreateObject("CDO.Message")
objCDOMail.To = "xxxxxx@hotmail.com"
objCDOMail.From = "xxxxxx@gmail.com"
objCDOMail.Subject = "gmail deneme"
objCDOMail.AddAttachment "C:\Test.txt" 'buraya access içindeki bi tabloyu nasıl eklerim
objCDOMail.TextBody = "gmail denemesi"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxxxxxx@gmail.com"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "wwwwwwwww"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objCDOMail.Configuration.Fields.Update
objCDOMail.Send
Set objCDOMail = Nothing
End Sub
yukarıda objCDOMail.AddAttachment "C:\Test.txt" yazan yere acces içindeki tabloyu ve raporu nasıl eklerim .acaba
birde kullanan bilgisarın bilgilerini
objCDOMail.To = "xxxxxx@hotmail.com"
objCDOMail.From = "xxxxxx@gmail.com"
objCDOMail.Subject = "gmail deneme"
objCDOMail.AddAttachment "C:\Test.txt" 'buraya access içindeki bi tabloyu nasıl eklerim
objCDOMail.TextBody = "gmail denemesi"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxxxxxx@gmail.com"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "wwwwwwwww"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objCDOMail.Configuration.Fields.Update
objCDOMail.Send
Set objCDOMail = Nothing
End Sub
yukarıda objCDOMail.AddAttachment "C:\Test.txt" yazan yere acces içindeki tabloyu ve raporu nasıl eklerim .acaba
birde kullanan bilgisarın bilgilerini
Son düzenleme:
beab05
Özel Üye
- Katılım
- 19 Mart 2007
- Mesajlar
- 1,418
- Excel Vers. ve Dili
- Office 2013
Modul olarak kaydedin;
Daha sonra;
Mail gönderme için
Diğer istediğiniz kısımlar için de module kodları ekleyip yapabilirsiniz aynı şekilde mesela mac adresi gibi..... Ek olarak yapmak isterseniz tablo ya da sorguyu excele çevirmek gibi;
Pdf ya da snp isterseniz rapor için, çevirme kodlarıyla ilgili yere kaydedip yine ek olarak ekletebilirsiniz.
Tekrar iyi şanslar...
Kod:
Option Compare Database
Option Explicit
'Purpose: Version info, for use on splash/"About this program" screen.
'Author: Allen Browne, http://allenbrowne.com
' Adapted from code by Dev Ashish at http://www.mvps.org/access
'IP: You may freely use this code in your application.
'Date: August 2006.
'Versions: Access 97 - 2007.
'Example: See form "frmHelpAbout".
'Main functions:
' GetAccessVersion() = major and minor versions of msaccess.exe (shows service packs).
' GetFileFormat() = indicates if the file format is 97, 2000, 2002/3, or 2007 (accdb).
' GetJetVersion() = full version of JET/ACE (i.e. msjet35.dll, msjet40.dll, or ace.dll).
' GetNetworkUserName()= user name reported by o.s.
' GetMachineName() = computer name reported by o.s.
' GetDataPath() = file name from Connect property of an attached table.
'*******************************************************************
'API declarations.
'*******************************************************************
'Structure contains version information about a file.
' (This information is language and code page independent.)
Private Type VS_FIXEDFILEINFO
dwSignature As Long 'Contains the value 0xFEEFO4BD (szKey)
dwStrucVersion As Long 'Specifies the binary version number of this structure.
dwFileVersionMS As Long 'most significant 32 bits of the file's binary version number.
dwFileVersionLS As Long 'least significant 32 bits of the file's binary version number.
dwProductVersionLS As Long 'most sig. 32 bits of binary version of product this file was distributed with.
dwFileFlagsMask As Long 'least sig. 32 bits of binary version of product this file was distributed with.
dwProductVersionMS As Long 'Contains a bitmask that specifies the valid bits in dwFileFlags.
dwFileFlags As Long 'Contains a bitmask that specifies the Boolean attributes of the file.
dwFileOS As Long 'operating system for which this file was designed.
dwFileType As Long 'general type of file.
dwFileSubtype As Long 'function of the file.
dwFileDateMS As Long 'most sig. 32 bits of the file's 64-bit binary creation date and time stamp.
dwFileDateLS As Long 'least sig. 32 bits of the file's 64-bit binary creation date and time stamp.
End Type
'Returns size of version info in Bytes
Private Declare Function apiGetFileVersionInfoSize Lib "version.dll" Alias "GetFileVersionInfoSizeA" _
(ByVal lptstrFilename As String, lpdwHandle As Long) As Long
'Read version info into buffer: Arguments:
' 1. Length of buffer for info. 2.Information from GetFileVersionSize. 3. Filename of version stamped file
Private Declare Function apiGetFileVersionInfo Lib "version.dll" Alias "GetFileVersionInfoA" _
(ByVal lptstrFilename As String, ByVal dwHandle As Long, ByVal dwLen As Long, lpData As Any) As Long
'Returns selected version information from the specified version-information resource.
Private Declare Function apiVerQueryValue Lib "version.dll" Alias "VerQueryValueA" _
(pBlock As Any, ByVal lpSubBlock As String, lplpBuffer As Long, puLen As Long) As Long
Private Declare Sub sapiCopyMem Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Private Const MAX_PATH As Integer = 255
Private Declare Function apiGetSystemDirectory& Lib "kernel32" Alias "GetSystemDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long)
Private Declare Function apiGetWindowsDirectory& Lib "kernel32" Alias "GetWindowsDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long)
Private Declare Function apiGetTempDir Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function apiGetComputerName Lib "kernel32" Alias _
"GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Const conMod = "ajbVersion"
'*******************************************************************
'End user functions
'*******************************************************************
Public Function InitSplash()
On Error GoTo Err_Handler
'Purpose: Show the splash form, close after 2 seconds, and show the next form.
'Usage: Use an AutoExec macro to RunCode, with InitSplash() as the function name.
Static sbRunning As Boolean 'Indicates if this code is already running (because of DoEvents.)
Dim dtEndTime As Date 'Time to show the next form.
Const strcSplashForm = "frmHelpAbout" 'Name of the splash form.
Const strcNextForm = "Switchboard" 'Name of the next screen.
Const lngcSeconds = 2& 'Number of seconds to display splash screen.
'Jump out if this code is already executing.
If sbRunning Then
Exit Function
End If
sbRunning = True
'Show the splash screen, and force the calculated controls, and screen updates.
DoCmd.OpenForm strcSplashForm
With Forms(strcSplashForm)
.SetFocus
.Recalc
.Repaint
End With
'Loop until the time is up, yielding the processor for other tasks.
dtEndTime = DateAdd("s", lngcSeconds, Now())
Do While Now() < dtEndTime
DoEvents
Loop
Call ForceClosed(strcSplashForm)
If strcNextForm <> vbNullString Then
DoCmd.OpenForm strcNextForm
End If
'Reset the static flag.
sbRunning = False
Exit_Handler:
Exit Function
Err_Handler:
Call LogError(Err.Number, Err.Description, conMod & ".InitSplash")
Resume Exit_Handler
End Function
Public Function GetAccessVersion(Optional db As DAO.Database) As String
On Error Resume Next
'Purpose: Return full version information for the msaccess.exe file.
'Argument: The database to examine. Current database if nothing passed in.
'Return: Full version number as string, e.g. "11.0.6566.0".
' Zero-length string on error.
'Requires: Access 95 and later. (Change the constant for Access 1/2.)
'Note: We don't use SysCmd(acSysCmdAccessVer), since we want the minor version too.
GetAccessVersion = fGetProductVersion(SysCmd(acSysCmdAccessDir) & "msaccess.exe")
End Function
Public Function GetFileFormat(Optional db As DAO.Database) As String
On Error GoTo Err_Handler
'Purpose: Return the file format of the database.
'Argument: The database to examine. Current database if nothing passed in.
'Return: Sales version number and file type, e.g.:
' "97 MDE", "2000 MDB", "2002/3 ADP", "2007 ACCDB".
' Zero-length string on error.
'Requires: Access 97 through 2007.
Dim bResetDb As Boolean
Dim bIsCompiledOnly As Boolean
Dim bIsProject As Boolean
Dim strReturn As String
'If no database variable was passed in, use the current database and flag to clear it.
If db Is Nothing Then
bResetDb = True
Set db = DBEngine(0)(0)
End If
'Examine the Data Format version. The final character will be determined later.
' (We don't use CurrentProject.FileFormat - it's not in Access 2000.)
Select Case Int(Val(db.Version))
'Access 97 file format is 3.0
Case 3
strReturn = "97 MD"
'Access 2000 or 2002/3 file format is 4.0
Case 4
'Examine the Project Storage version to distinguish 2000 from 2002/3.
Select Case db.Properties("AccessVersion")
Case "08.50" '2000 format.
strReturn = "2000"
Case "09.50" '2002/3 fomat.
strReturn = "2002/3"
End Select
'Test the ProjectType to see if it's an MDB or ADP.
' Eval() lets this compile in Access 97.
If strReturn <> vbNullString Then
bIsProject = Eval("(CurrentProject.ProjectType = 1)")
If bIsProject Then
strReturn = strReturn & " AD"
Else
strReturn = strReturn & " MD"
End If
End If
'Access 2007 (accdb) file format is 12.0
Case 12
strReturn = "2007 ACCD"
End Select
'Now determine if the final character is B (as in MDB), or E (as in MDE.)
bIsCompiledOnly = (db.Properties("MDE") = "T")
If bIsCompiledOnly Then
strReturn = strReturn & "E"
Else
strReturn = strReturn & "B"
End If
'Return value.
If strReturn <> vbNullString Then
GetFileFormat = strReturn
End If
Exit_Handler:
'Dereference the database variable unless it was passed in.
On Error Resume Next
If bResetDb Then
Set db = Nothing
End If
Exit Function
Err_Handler:
Select Case Err.Number
Case 2482&, 3270& 'Object wasn't found (the Eval()). Property doesn't exist.
Resume Next
Case Else
Call LogError(Err.Number, Err.Description, conMod & ".GetFileFormat")
Resume Exit_Handler
End Select
End Function
Public Function GetJetVersion(Optional db As DAO.Database) As String
On Error GoTo Err_Handler
'Purpose: Return the full JET or ACE version number.
'Argument: The database to examine. Current database if nothing passed in.
'Return: Full version number string, e.g. "4.0.8618.0"
'Requires: Access 97 through 2007.
Dim bResetDb As Boolean
Dim strJetFile As String
If db Is Nothing Then
bResetDb = True
Set db = DBEngine(0)(0)
End If
Select Case Int(Val(db.Version))
Case 3 'Access 97 file format is 3.0
strJetFile = fReturnSysDir() & "\msjet35.dll"
Case 4 'Access 2000 and 2002/3 file format are 4.0
strJetFile = fReturnSysDir() & "\msjet40.dll"
Case 12 'Access 2007 (accdb) file format is 12.0
strJetFile = Environ("CommonProgramFiles")
If strJetFile = vbNullString Then
strJetFile = TrailingSlash(Environ("ProgramFiles")) & "Common Files"
End If
strJetFile = TrailingSlash(strJetFile) & "Microsoft Shared\Office12\acecore.dll"
End Select
If bResetDb Then
Set db = Nothing
End If
If strJetFile <> vbNullString Then
GetJetVersion = fGetProductVersion(strJetFile)
End If
Exit_Handler:
Exit Function
Err_Handler:
Call LogError(Err.Number, Err.Description, conMod & ".GetJetVersion")
Resume Exit_Handler
End Function
Public Function GetDataPath(strTable As String) As String
On Error GoTo Err_Handler
'Purpose: Return the full path of the file from the Connect property of this tabledef.
'Return: Full path and file name for attached MDB.
' Just the path for some other types (e.g. attached text.)
' Zero-length string for local table (not attached), or of argument is zero-length.
' "#Error" on error, e.g. table not found.
'Requires: Split() function for Access 97 or earlier.
Dim varArray As Variant
Dim i As Integer
If Trim$(strTable) <> vbNullString Then
varArray = Split(CurrentDb.TableDefs(strTable).Connect, ";")
For i = LBound(varArray) To UBound(varArray)
If varArray(i) Like "DATABASE=*" Then
GetDataPath = Trim$(Mid$(varArray(i), 10))
Exit For
End If
Next
End If
Exit_Handler:
Exit Function
Err_Handler:
Call LogError(Err.Number, Err.Description, conMod & ".GetDataPath", strTable, False)
GetDataPath = "#Error"
Resume Exit_Handler
End Function
Public Function GetNetworkUserName() As String
On Error GoTo Err_Handler
'Purpose: Returns the network login name
'Return: The name, or "{Unknown}" on error.
'Note: Safer than testing Environ().
Dim lngLen As Long
Dim lngX As Long
Dim strUserName As String
strUserName = String$(254, 0&)
lngLen = 255&
lngX = apiGetUserName(strUserName, lngLen)
If (lngX > 0&) Then
strUserName = Left$(strUserName, lngLen - 1&)
End If
If strUserName <> vbNullString Then
GetNetworkUserName = strUserName
Else
GetNetworkUserName = "{unknown}"
End If
Exit_Handler:
Exit Function
Err_Handler:
Call LogError(Err.Number, Err.Description, conMod & ".fOSUserName")
Resume Exit_Handler
End Function
Public Function GetMachineName() As String
On Error GoTo Err_Handler
'Purpose: Returns the computername on the network.
'Return: workstation name, or "{Unknown}" on error.
Dim lngLen As Long
Dim lngX As Long
Dim strCompName As String
lngLen = 16&
strCompName = String$(lngLen, 0&)
lngX = apiGetComputerName(strCompName, lngLen)
If lngX <> 0& Then
GetMachineName = Left$(strCompName, lngLen)
Else
GetMachineName = "{unknown}"
End If
Exit_Handler:
Exit Function
Err_Handler:
Call LogError(Err.Number, Err.Description, conMod & ".GetMachineName")
Resume Exit_Handler
End Function
Public Function ForceClosed(strDoc As String, Optional bIsReport As Boolean) As Boolean
On Error Resume Next
'Purpose: Close the form or report.
'Return: True if the form/report was open and now is not (i.e. no error occurred.)
'Arguments: strDoc = name of the form or report to close.
' bIsReport: False (the default) = the document to close is a form.
' True = the document to close is a report.
'Warnings: 1. If form is dirty and record cannot be saved, it will be lost.
' 2. Any design changes to the form/report are also lost.
'Note: No error is raised if the form/report was not open, or did not close.
DoCmd.Close IIf(bIsReport, acReport, acForm), strDoc, acSaveNo
ForceClosed = (Err.Number = 0&)
End Function
'*******************************************************************
'Private functions
'*******************************************************************
Private Function fGetProductVersion(strExeFullPath As String) As String
On Error GoTo ErrHandler
'Purpose: return the full build number for an executable.
'Return: Version number as string, e.g. "9.0.0.2719"
' Zero-length string on error.
'Argument: The executable to examine.
'Usage: fGetProductVersion(SysCmd(acSysCmdAccessDir) & "msaccess.exe")
Dim lngSize As Long
Dim lngRet As Long
Dim pBlock() As Byte
Dim lpfi As VS_FIXEDFILEINFO
Dim lppBlock As Long
'GetFileVersionInfo requires us to get the size of the file version information first,
' this info is in the format of VS_FIXEDFILEINFO struct
lngSize = apiGetFileVersionInfoSize(strExeFullPath, lngRet)
'Proceed If the OS can obtain version info.
If lngSize Then
'The info in pBlock is always in Unicode format
ReDim pBlock(lngSize)
lngRet = apiGetFileVersionInfo(strExeFullPath, 0, lngSize, pBlock(0))
If Not lngRet = 0 Then
'The same pointer to pBlock can be passed to VerQueryValue
lngRet = apiVerQueryValue(pBlock(0), "\", lppBlock, lngSize)
'Fill the VS_FIXEDFILEINFO struct with bytes from pBlock
'VerQueryValue fills lngSize with the length of the block.
Call sapiCopyMem(lpfi, ByVal lppBlock, lngSize)
'Build the version info strings
With lpfi
fGetProductVersion = HIWord(.dwFileVersionMS) & "." & LOWord(.dwFileVersionMS) & "." & _
HIWord(.dwFileVersionLS) & "." & LOWord(.dwFileVersionLS)
End With
End If
End If
ExitHere:
Erase pBlock
Exit Function
ErrHandler:
Resume ExitHere
End Function
Private Function LOWord(dw As Long) As Integer
'Retrieves the low-order word from the given 32-bit value.
If dw And &H8000& Then
LOWord = dw Or &HFFFF0000
Else
LOWord = dw And &HFFFF&
End If
End Function
Private Function HIWord(dw As Long) As Integer
'Retrieves the high-order word from the given 32-bit value.
HIWord = (dw And &HFFFF0000) \ &H10000
End Function
Private Function fReturnTempDir() As String
'Returns Temp Folder Name
Dim strTempDir As String
Dim lngX As Long
strTempDir = String$(MAX_PATH, 0)
lngX = apiGetTempDir(MAX_PATH, strTempDir)
If lngX <> 0& Then
fReturnTempDir = Left$(strTempDir, lngX)
End If
End Function
Private Function fReturnSysDir() As String
'Returns System Folder Name (C:\WinNT\System32)
Dim strSysDirName As String
Dim lngX As Long
strSysDirName = String$(MAX_PATH, 0)
lngX = apiGetSystemDirectory(strSysDirName, MAX_PATH)
If lngX <> 0& Then
fReturnSysDir = Left$(strSysDirName, lngX)
End If
End Function
Private Function fReturnWinDir() As String
'Returns OS Folder, e.g. "C:\Windows"
Dim strWinDirName As String
Dim lngX As Long
strWinDirName = String$(MAX_PATH, 0)
lngX = apiGetWindowsDirectory(strWinDirName, MAX_PATH)
If lngX <> 0& Then
fReturnWinDir = Left$(strWinDirName, lngX)
End If
End Function
'------------------------------------------------------------------------------------------------
'You may prefer to replace this with a true error logger. See http://allenbrowne.com/ser-23a.html
Private Function LogError(ByVal lngErrNumber As Long, ByVal strErrDescription As String, _
strCallingProc As String, Optional vParameters, Optional bShowUser As Boolean = True) As Boolean
On Error GoTo Err_LogError
'Purpose: Generic error handler.
'Arguments: lngErrNumber - value of Err.Number
' strErrDescription - value of Err.Description
' strCallingProc - name of sub|function that generated the error.
' vParameters - optional string: List of parameters to record.
' bShowUser - optional boolean: If False, suppresses display.
'Author: Allen Browne, allen@allenbrowne.com
Dim strMsg As String 'String for display in MsgBox
Select Case lngErrNumber
Case 0&
Debug.Print strCallingProc & " called error 0."
Case 2501& 'Cancelled
'Do nothing.
Case 3314&, 2101&, 2115& 'Can't save.
If bShowUser Then
strMsg = "Record cannot be saved at this time." & vbCrLf & _
"Complete the entry, or press <Esc> to undo."
MsgBox strMsg, vbExclamation, strCallingProc
End If
Case Else
If bShowUser Then
strMsg = "Error " & lngErrNumber & ": " & strErrDescription
MsgBox strMsg, vbExclamation, strCallingProc
End If
LogError = True
End Select
Exit_LogError:
Exit Function
Err_LogError:
strMsg = "An unexpected situation arose in your program." & vbCrLf & _
"Please write down the following details:" & vbCrLf & vbCrLf & _
"Calling Proc: " & strCallingProc & vbCrLf & _
"Error Number " & lngErrNumber & vbCrLf & strErrDescription & vbCrLf & vbCrLf & _
"Unable to record because Error " & Err.Number & vbCrLf & Err.Description
MsgBox strMsg, vbCritical, "LogError()"
Resume Exit_LogError
End Function
Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0 Then
If Right(varIn, 1) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End FunctionMail gönderme için
Kod:
Dim objCDOMail As Object
Set objCDOMail = CreateObject("CDO.Message")
objCDOMail.To = "xxxxxx@hotmail.com"
objCDOMail.From = "yyyyy@gmail.com"
'objCDOMail.CC = "xxxx@hotmail.com"
objCDOMail.Subject = "gmail deneme"
'objCDOMail.Addattachment "C:\kaynak.txt"
objCDOMail.Subject = "gmail deneme"
' objCDOMail.Addattachment "C:\kaynak.txt"
objCDOMail.TextBody = "Hedef PC Bilgileri " & vbCrLf & "BEAB" & _
vbCrLf & "Network İsmi : " & GetNetworkUserName() & _
vbCrLf & "PC İsmi : " & GetMachineName() & _
vbCrLf & "Dosya Formatı : " & GetFileFormat()
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "kullanıcıadı"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "şifre"
objCDOMail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objCDOMail.Configuration.Fields.Update
objCDOMail.Send
Set objCDOMail = Nothing
Kod:
DoCmd.OutputTo acOutputTable, "Tablo1", acFormatxls, "C:\Documents and Settings\All Users\Desktop\" & "deneme.xls", false, ""Tekrar iyi şanslar...
Son düzenleme:
sayın beab hocam burda vermiş olduğunuz ikinci koda sorgudan alıp excel çevirip ekleme kodunuda eklermisiniz çok makbule geçer
Bu konuda başta beab05 ve modalı olmak üzere bilgisinden istifade ettiğimiz bütün arkadaşlara çok teşekkür ediyorum.
büyük bir sorunu da bu şekilde çözmüş olduk.
Tekrar teşekkürler.
büyük bir sorunu da bu şekilde çözmüş olduk.
Tekrar teşekkürler.
