AccessTr.neT

Tam Versiyon: SMTP Hesabıyla E-mail Gönderme Uygulaması
Şu anda arşiv modunu görüntülemektesiniz. Tam versiyonu görüntülemek için buraya tıklayınız.
Sayfalar: 1 2 3 4 5 6
(25/04/2011, 22:25)sledgeab yazdı: [ -> ]Veritabanının bozulmasından kaynaklanan sorun var.

Ekteki uygulamayı deneyiniz.

Sn sledgeab,ekteki uygulamayı da denedim maalesef aynı hatayı veriyor. Üstelik farklı bilgisayarlarda da denedim. Programı kendi veri tabanında açtığımda çalışıyor. Dosyaları kendi yaptığım veri tabanına alınca maalesef çalışmıyor. Oysa yaptığım programa mail gönderme (sizin yaptığınız programı eklemeyi ) çok istiyordum...
3 bilgisayarda sorunsuz çalıştı. 1 bilgisayarda basOpenFile harici modüllerden birisi (tespit etmeye fırsatım olmadı) hataya sebep oluyor. basOpenFile dışındaki tüm modülleri silerek deneyiniz.

Ayrıca bu uygulamayı kullanabilmek için smtp hesabınızın olması gerekiyor.
sn sledgeab, söylediğinizi denedim. Modül1 silince program çalıştı. Modül 1 sanırım Treewiev çalıştıran modül. sanırım iki modülü çakıştıran bir fonksiyon var. Treewiev menüsünü programdan silmenin imkanı yok. Acaba iki uygulamayıda kullanmanın bir yolu yokmu.

Bu arada gösterdiğiniz sabır ve emeğiniz içinde çok teşekkür ederim.
Muhtemelen Modül1'deki "Function Split" problem çıkarıyor. Bu fonksiyonu silerek deneyiniz,
denedim problem burdan kaynaklanıyor, ama bunu silincede busefer treewiev menüsü çalışmıyor.
Function Split
fonksiyonunun adını değiştir.
Function Splitx yap
modülü aşağıdaki kodlarla değiştir
Option Compare Database
Option Explicit

Private Type Size
cx As Long
cy As Long
End Type

Private Const LF_FACESIZE = 32

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 * LF_FACESIZE
End Type

Private Declare Function apiCreateFontIndirect Lib "gdi32" Alias _
"CreateFontIndirectA" (lplogfont As LOGFONT) As Long

Private Declare Function apiSelectObject Lib "gdi32" _
Alias "SelectObject" (ByVal hDC As Long, ByVal hObject As Long) As Long

Private Declare Function apiGetDC Lib "user32" _
Alias "GetDC" (ByVal hwnd As Long) As Long

Private Declare Function apiReleaseDC Lib "user32" _
Alias "ReleaseDC" (ByVal hwnd As Long, _
ByVal hDC As Long) As Long

Private Declare Function apiDeleteObject Lib "gdi32" _
Alias "DeleteObject" (ByVal hObject As Long) As Long

Private Declare Function apiGetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, _
lpSize As Size) As Long

Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Any) As Long

Declare Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" _
(ByVal hDC As Long) As Long

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Const SM_CXVSCROLL = 2
Private Const LOGPIXELSX = 88
Function SY(MyForm As String, myctl As String, myfield As Variant, _
col As Integer, RightOrCenter As Integer, Optional Sform As String = "") As Variant

Dim UserControl As Control
Dim UserForm As Form
Dim lngWidth As Long

Dim intSize As Integer
Dim strText As String
Dim lngL As Long
Dim strColumnWidths As String
Dim lngColumnWidth As Long
Dim lngScrollBarWidth As Long
Dim lngOneSpace As Long
Dim lngFudge As Long
Dim arrCols() As String
Dim lngRet As Long

On Error Resume Next
lngFudge = 60
If Len(Sform & vbNullString) > 0 Then
Set UserForm = Forms(MyForm).Controls(Sform).Form
Else
Set UserForm = Forms(MyForm)
End If

Set UserControl = UserForm.Controls.Item(myctl)

With UserControl
If col > Splitx(arrCols(), .ColumnWidths, ";") Then Exit Function
If col = .ColumnCount - 1 Then
lngScrollBarWidth = GetSystemMetrics(SM_CXVSCROLL)
lngScrollBarWidth = lngScrollBarWidth * (1440 / GetTwipsPerPixel())
End If
lngColumnWidth = Nz(Val(arrCols(col)), 1)
lngColumnWidth = lngColumnWidth - (lngScrollBarWidth + lngFudge)
End With
strText = " "
lngWidth = StringToTwips(UserControl, strText)
If lngWidth > 0 Then
lngOneSpace = Nz(lngWidth, 0)
lngWidth = 0
Select Case VarType(myfield)

Case 1 To 6, 7

strText = Str$(myfield)

Case 8

strText = myfield

Case Else

Call MsgBox("Field type must be Numeric, Date or String", vbOKOnly)

End Select


strText = Trim$(strText)

lngWidth = StringToTwips(UserControl, strText)


If lngWidth > 0 Then

Select Case RightOrCenter
Case -1

strText = String(Int((lngColumnWidth - lngWidth) / lngOneSpace), " ") & strText

Case 0

strText = String((Int((lngColumnWidth - lngWidth) / lngOneSpace) / 2), " ") & strText _
& String((Int((lngColumnWidth - lngWidth) / lngOneSpace) / 2), " ")

Case 1

strText = strText

Case Else
End Select

SY = strText
End If
End If


Set UserControl = Nothing
Set UserForm = Nothing

End Function



Function Splitx(ArrayReturn() As String, ByVal StringToSplitx As String, _
SplitxAt As String) As Integer
Dim intInstr As Integer
Dim intCount As Integer
Dim strTemp As String

intCount = -1
intInstr = InStr(StringToSplitx, SplitxAt)
Do While intInstr > 0
intCount = intCount + 1
ReDim Preserve ArrayReturn(0 To intCount)
ArrayReturn(intCount) = Left(StringToSplitx, intInstr - 1)
StringToSplitx = Mid(StringToSplitx, intInstr + 1)
intInstr = InStr(StringToSplitx, SplitxAt)
Loop
If Len(StringToSplitx) > 0 Then
intCount = intCount + 1
ReDim Preserve ArrayReturn(0 To intCount)
ArrayReturn(intCount) = StringToSplitx
End If
Splitx = intCount
End Function



Private Function StringToTwips(ctl As Control, strText As String) As Long
Dim myfont As LOGFONT
Dim stfSize As Size
Dim lngLength As Long
Dim lngRet As Long
Dim hDC As Long
Dim lngscreenXdpi As Long
Dim fontsize As Long
Dim hfont As Long, prevhfont As Long


hDC = apiGetDC(0&)


lngscreenXdpi = GetTwipsPerPixel()
With myfont
.lfFaceName = ctl.FontName & Chr$(0)
fontsize = ctl.fontsize
.lfWeight = ctl.FontWeight
.lfItalic = ctl.FontItalic
.lfUnderline = ctl.FontUnderline
.lfHeight = (fontsize / 72) * -lngscreenXdpi
End With

hfont = apiCreateFontIndirect(myfont)
prevhfont = apiSelectObject(hDC, hfont)

lngLength = Len(strText)
lngRet = apiGetTextExtentPoint32(hDC, strText, lngLength, stfSize)

hfont = apiSelectObject(hDC, prevhfont)

lngRet = apiDeleteObject(hfont)

lngRet = apiReleaseDC(0&, hDC)

StringToTwips = stfSize.cx * (1440 / GetTwipsPerPixel())

End Function


Private Function GetTwipsPerPixel() As Integer

Dim lngIC As Long
lngIC = apiCreateIC("DISPLAY", vbNullString, _
vbNullString, vbNullString)

If lngIC <> 0 Then
GetTwipsPerPixel = GetDeviceCaps(lngIC, LOGPIXELSX)
apiDeleteDC lngIC
Else
GetTwipsPerPixel = 120
End If
End Function

Sayfalar: 1 2 3 4 5 6