اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

برنامج الارشيف الالكتروني لايعمل على نظام تشغيل 8 و10


الردود الموصى بها

اساتذتي الافاضل السلام عليكم ورحمة الله وبركاته

عندي برنامج الارشيف الالكتروني معمول باوفيس 2003 بحيث استخدمه بدون مشاكل في نظام تشغيل 7 

ولكنه لايعمل على نظام تشغيل 8 ولا على  نظام تشغيل 10 

هل من مساعدة واذا تطلب الامر لارفاق البرنامج سوف ارفقه لكم مع وافر التحايا 

رابط هذا التعليق
شارك

51 دقائق مضت, حربي العنزي said:

اساتذتي الافاضل السلام عليكم ورحمة الله وبركاته

عندي برنامج الارشيف الالكتروني معمول باوفيس 2003 بحيث استخدمه بدون مشاكل في نظام تشغيل 7 

ولكنه لايعمل على نظام تشغيل 8 ولا على  نظام تشغيل 10 

هل من مساعدة واذا تطلب الامر لارفاق البرنامج سوف ارفقه لكم مع وافر التحايا 

فضلا وكرما ارفاق قاعدة البيانات لكى تتم التجربة على الانظمة المختلفة :wink2:

رابط هذا التعليق
شارك

اساتذتي الافاضل محتاج مساعدتكم معي في هذا الموضوع 

البرنامج يعمل بشكل جيد على الحاسبات القديمة ولكن لايعمل على الحاسبات الحديثة مثل حاسبات CORE i3 وصاعدا وخاصة نظام تشغيل 7 و 8 و10 

رابط هذا التعليق
شارك

استاذي الفاضل محمد ايمن السلام عليكم ورحمة الله وبركاته

المشكلة كالتالي : طبعا بعد ما اقوم بنسخ الاداة في الوندوز في الفولدر الذي اسمه سيستم 32 ثم افتح البرنامج ينفتح البرنامج لكن عند الضغط على زر امر 

قم بتحديد واختيار الماسح الضوئي هذا الامر لايستجيب لكن عندما انقل البرنامج ال حاسبة اقل من core i3 البرنامج يعمل بشكل جيد جدا وبدون مشاكل 

اذن في الحاسبات ال XP وال 7 التي هي اقل من core i3 فما دون البرنامج يعمل بينما حسابات الحديثة من core i3  الى  core i7 البرنامج لايعمل 

هل من حل لهذه المشكلة مع جزيل الشكر والاحترام

رابط هذا التعليق
شارك

السلام عليكم:smile:

 

الموضوع التالي يستخدم نفس كود برنامجك تقريبا :

.

ولكن للأسف ما اشتغل على جهازي وندوز 10 !!

وبحثت ، وعرفت ان الكود يعمل على XP و Vista ولا يعمل على 7 او 8 او 10 ،

ولكن الكود التالي يعمل عندي ، وطرق مناداته:

1. لإختيار الجهاز ،

2. لإظهار نافذة جهاز الاسكانر ،

3. للنسخ من الاسكانر بدون نوافذ:

1.
PopupSelectSourceDialog

2.
TransferWithUI("d:\j.bmp")

3.
TransferWithoutUI(300, rgb, 0, 0, 8.3, 11.7,"D:\jj2.bmp")
Option Compare Database

'*******************************************************************************
'
' Description: VB Module for accessing TWAIN compatible scanner (VB 5, 6)
'
' Author:      Lumir Mik (lmik@seznam.cz)
'
' Version:     1.0
'
' License:     Free to any use. If you change some part of this code, please,
'              mention it here.
'              Receive it as my contribution to free programmer sources
'              in which I found much help and inspiration.
'
' There are 3 public functions in this module:
'
'   1. PopupSelectSourceDialog
'           shows TWAIN dialog for selecting default source for acquisition
'
'   2. TransferWithoutUI
'           transfers one image from TWAIN data source without showing
'           the data source user interface (silent transfer). The programmer
'           can set following attributes of the image:
'               - resolution (DPI)
'               - colour depth - monochromatic, grey, fullcolour
'               - image size and position on the scanner glass
'                       - left, top, right, bottom (in inches).
'           The image is saved into the BMP file.
'
'   3. TransferWithUI
'           transfers one image from TWAIN data source using the data
'           source user interface to set image attributes.
'           The image is saved into the BMP file.
'
'*******************************************************************************

Option Explicit

'-----------------------------
' Declaration for TWAIN_32.DLL
'-----------------------------
Private Declare Function DSM_Entry Lib "Twain_32.dll" _
                                   (ByRef pOrigin As Any, _
                                    ByRef pDest As Any, _
                                    ByVal DG As Long, _
                                    ByVal DAT As Integer, _
                                    ByVal MSG As Integer, _
                                    ByRef pData As Any) As Integer

Private Type TW_VERSION
    MajorNum        As Integer                  ' TW_UINT16
    MinorNum        As Integer                  ' TW_UINT16
    Language        As Integer                  ' TW_UINT16
    Country         As Integer                  ' TW_UINT16
    Info(1 To 34)   As Byte                     ' TW_STR32
End Type

Private Type TW_IDENTITY
    Id                      As Long             ' TW_UINT32
    Version                 As TW_VERSION       ' TW_VERSION
    ProtocolMajor           As Integer          ' TW_UINT16
    ProtocolMinor           As Integer          ' TW_UINT16
    SupportedGroups1        As Integer          ' TW_UINT32
    SupportedGroups2        As Integer
    Manufacturer(1 To 34)   As Byte             ' TW_STR32
    ProductFamily(1 To 34)  As Byte             ' TW_STR32
    ProductName(1 To 34)    As Byte             ' TW_STR32
End Type

Private Type TW_USERINTERFACE
    ShowUI   As Integer                         ' TW_BOOL
    ModalUI  As Integer                         ' TW_BOOL
    hParent  As Long                            ' TW_HANDLE
End Type

Private Type TW_PENDINGXFERS
    Count       As Integer                      ' TW_UINT16
    Reserved1   As Integer                      ' TW_UINT32
    Reserved2   As Integer
End Type

Private Type TW_ONEVALUE
    ItemType As Integer                         ' TW_UINT16
    Item1    As Integer                         ' TW_UINT32
    Item2    As Integer
End Type

Private Type TW_CAPABILITY
    Cap          As Integer                     ' TW_UINT16
    ConType      As Integer                     ' TW_UINT16
    hContainer   As Long                        ' TW_HANDLE
End Type

Private Type TW_FIX32
    Whole   As Integer                          ' TW_INT16
    Frac    As Integer                          ' TW_UINT16
End Type

Private Type TW_FRAME
    Left     As TW_FIX32                        ' TW_FIX32
    Top      As TW_FIX32                        ' TW_FIX32
    Right    As TW_FIX32                        ' TW_FIX32
    Bottom   As TW_FIX32                        ' TW_FIX32
End Type

Private Type TW_IMAGELAYOUT
    Frame            As TW_FRAME                ' TW_FRAME
    DocumentNumber   As Long                    ' TW_UINT32
    PageNumber       As Long                    ' TW_UINT32
    FrameNumber      As Long                    ' TW_UINT32
End Type

Private Type TW_EVENT
    pEvent      As Long                         ' TW_MEMREF
    TWMessage   As Integer                      ' TW_UINT16
End Type

Private Const DG_CONTROL = 1
Private Const DG_IMAGE = 2

Private Const MSG_GET = 1
Private Const MSG_SET = 6
Private Const MSG_XFERREADY = 257
Private Const MSG_CLOSEDSREQ = 258
Private Const MSG_OPENDSM = 769
Private Const MSG_CLOSEDSM = 770
Private Const MSG_OPENDS = 1025
Private Const MSG_CLOSEDS = 1026
Private Const MSG_USERSELECT = 1027
Private Const MSG_DISABLEDS = 1281
Private Const MSG_ENABLEDS = 1282
Private Const MSG_PROCESSEVENT = 1537
Private Const MSG_ENDXFER = 1793

Private Const DAT_CAPABILITY = 1
Private Const DAT_EVENT = 2
Private Const DAT_IDENTITY = 3
Private Const DAT_PARENT = 4
Private Const DAT_PENDINGXFERS = 5
Private Const DAT_USERINTERFACE = 9
Private Const DAT_IMAGELAYOUT = 258
Private Const DAT_IMAGENATIVEXFER = 260

Private Const TWRC_SUCCESS = 0
Private Const TWRC_CHECKSTATUS = 2
Private Const TWRC_DSEVENT = 4
Private Const TWRC_NOTDSEVENT = 5
Private Const TWRC_XFERDONE = 6

Private Const TWLG_CZECH = 45

Private Const TWCY_CZECHOSLOVAKIA = 42

Private Const TWON_PROTOCOLMAJOR = 1
Private Const TWON_ONEVALUE = 5
Private Const TWON_PROTOCOLMINOR = 9


'-------------------------
' Declaration for WIN32API
'-------------------------
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" _
                               (ByVal pDest As Long, _
                                ByVal pSource As Long, _
                                ByVal Length As Long)
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" _
                               (ByVal pDest As Long, _
                                ByVal Length As Long)
Private Declare Function GlobalFree Lib "kernel32.dll" _
                                    (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" _
                                    (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" _
                                      (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" _
                                     (ByVal wFlags As Long, _
                                      ByVal dwBytes As Long) As Long
Private Declare Function GetMessage Lib "user32.dll" Alias "GetMessageA" _
                                    (ByRef lpMsg As MSG, _
                                     ByVal hwnd As Long, _
                                     ByVal wMsgFilterMin As Long, _
                                     ByVal wMsgFilterMax As Long) As Long
Private Declare Function TranslateMessage Lib "user32.dll" _
                                          (ByRef lpMsg As MSG) As Long
Private Declare Function DispatchMessage Lib "user32.dll" Alias "DispatchMessageA" _
                                         (ByRef lpMsg As MSG) As Long
Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" _
                                        (ByVal dwExStyle As Long, _
                                         ByVal lpClassName As String, _
                                         ByVal lpWindowName As String, _
                                         ByVal dwStyle As Long, _
                                         ByVal x As Long, _
                                         ByVal y As Long, _
                                         ByVal nWidth As Long, _
                                         ByVal nHeight As Long, _
                                         ByVal hWndParent As Long, _
                                         ByVal hMenu As Long, _
                                         ByVal hInstance As Long, _
                                         ByVal lpParam As Long) As Long
Private Declare Function DestroyWindow Lib "user32.dll" _
                                       (ByVal hwnd As Long) As Long

Private Type BITMAPFILEHEADER
    bfType      As Integer
    bfSize      As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits   As Long
End Type

Private Type BITMAPINFOHEADER
    biSize          As Long
    biWidth         As Long
    biHeight        As Long
    biPlanes        As Integer
    biBitCount      As Integer
    biCompression   As Long
    biSizeImage     As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed       As Long
    biClrImportant  As Long
End Type

Private Type RGBQUAD
    rgbBlue     As Byte
    rgbGreen    As Byte
    rgbRed      As Byte
    rgbReserved As Byte
End Type

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type MSG
    hwnd    As Long
    message As Long
    wParam  As Long
    lParam  As Long
    time    As Long
    pt      As POINTAPI
End Type

Private Const GHND = 66


'----------------------------
' Declaration for this Module
'----------------------------
Private m_tAppID As TW_IDENTITY
Private m_tSrcID As TW_IDENTITY
Private m_lHndMsgWin As Long

Public Enum TWAIN_MDL_COLOURTYPE
    BW = 0                              ' TWPT_BW
    GREY = 1                            ' TWPT_GRAY
    rgb = 2                             ' TWPT_RGB
End Enum

Private Enum TWAIN_MDL_CAPABILITY
    XFERCOUNT = 1                       ' CAP_XFERCOUNT
    PIXELTYPE = 257                     ' ICAP_PIXELTYPE
    INDICATORS = 4107                   ' CAP_INDICATORS
    UICONTROLLABLE = 4110               ' CAP_UICONTROLLABLE
    PHYSICALWIDTH = 4369                ' ICAP_PSYSICALWIDTH
    PHYSICALHEIGHT = 4370               ' ICAP_PSYSICALHEIGHT
    XRESOLUTION = 4376                  ' ICAP_XRESOLUTION
    YRESOLUTION = 4377                  ' ICAP_YRESOLUTION
    BITDEPTH = 4395                     ' ICAP_BITDEPTH
End Enum

Private Enum TWAIN_MDL_ITEMYPE
    INT16 = 1                           ' TW_INT16      short
    UINT16 = 4                          ' TW_UINT16     unsigned short
    BOOL = 6                            ' TW_BOOL       unsigned short
    FIX32 = 7                           ' TW_FIX32      structure
End Enum

Public Function TransferWithoutUI(ByVal sngResolution As Single, _
                                  ByVal tColourType As TWAIN_MDL_COLOURTYPE, _
                                  ByVal sngImageLeft As Single, _
                                  ByVal sngImageTop As Single, _
                                  ByVal sngImageRight As Single, _
                                  ByVal sngImageBottom As Single, _
                                  ByVal sBMPFileName As String) As Long

    '----------------------------------------------------------------------------
    ' Function transfers one image from Twain data source without showing
    '   the data source user interface (silent transfer).
    '
    ' Input values
    '   - sngResolution (Single) - resolution of the image in DPI
    '                              (dots per inch)
    '   - tColourType (UDT) - colour depth of the imaged - monochromatic (BW),
    '                         colours of grey (GREY), full colours (COLOUR)
    '   - sngImageLeft, sngImageTop, sngImageRight, sngImageBottom (Single) -
    '       values determine the rectangle on the scanner glass that will
    '       be scanned (default units are inches) - if you set Right and Bottom
    '       values to 0, the module sets maximum values the scanner driver allows
    '       (the bottom right corner of the scanner glass)
    '   - sBMPFileName (String) - the file name of the saved image
    '
    ' Function returns 0 if OK, 1 if an error occurs
    '----------------------------------------------------------------------------
    ' TransferWithoutUI(300, rgb, 0, 0, 8.3, 11.7,"D:\jj2.bmp")
    '
    'Dim lRtn As Long
    'lRtn = mdlTwain.TransferWithoutUI(200, GREY, 0, 0, 0, 0,"noui_grey.bmp")
    '
    
    Dim lRtn As Long
    Dim lTmp As Long
    Dim blTwainOpen As Boolean
    Dim lhDIB As Long
    
    On Local Error GoTo ErrPlace

    '-------------------------------
    ' Open Twain Data Source Manager
    '-------------------------------
    lRtn = OpenTwainDSM()
    If lRtn Then GoTo ErrPlace
    blTwainOpen = True

    '-----------------------
    ' Open Twain Data Source
    '-----------------------
    lRtn = OpenTwainDS()
    If lRtn Then GoTo ErrPlace

    '-----------------------------------------------------------
    ' Set all important attributes of the image and the transfer
    '-----------------------------------------------------------
    
    '----------------------------------------------------------------------
    ' Set image size and position
    ' If sngImageRight or sngImageBottom is 0 put physical width and height
    '   of the scanner into these values
    '----------------------------------------------------------------------
    If (sngImageRight = 0) Or (sngImageBottom = 0) Then
        lRtn = TwainGetOneValue(PHYSICALWIDTH, sngImageRight)
        If lRtn Then GoTo ErrPlace
        lRtn = TwainGetOneValue(PHYSICALHEIGHT, sngImageBottom)
        If lRtn Then GoTo ErrPlace
    End If

    lRtn = SetImageSize(sngImageLeft, sngImageTop, sngImageRight, sngImageBottom)
    If lRtn Then GoTo ErrPlace

    '-----------------------------------------------
    ' Set the image resolution in DPI - both X and Y
    '-----------------------------------------------
    lRtn = TwainSetOneValue(XRESOLUTION, FIX32, sngResolution)
    If lRtn Then GoTo ErrPlace

    lRtn = TwainSetOneValue(YRESOLUTION, FIX32, sngResolution)
    If lRtn Then GoTo ErrPlace

    '--------------------------
    ' Set the image colour type
    '--------------------------
    lRtn = TwainSetOneValue(PIXELTYPE, UINT16, tColourType)
    If lRtn Then GoTo ErrPlace
    
    '----------------------------------------------------------------
    ' If the colour type is fullcolour, set the bitdepth of the image
    '   - 24 bits, 32 bits, ...
    '----------------------------------------------------------------
    If tColourType = rgb Then lRtn = TwainSetOneValue(BITDEPTH, UINT16, 24)

    '---------------------------------------------------
    ' Set number of images you want to transfer (just 1)
    '---------------------------------------------------
    lRtn = TwainSetOneValue(XFERCOUNT, INT16, 1)
    If lRtn Then GoTo ErrPlace

    '----------------------------------------------------
    ' TRANSFER the image with UI disabled.
    '   If successful, lhDIB is filled with handle to DIB
    '----------------------------------------------------
    lRtn = TwainTransfer(False, lhDIB)
    If lRtn Then GoTo ErrPlace

    '------------------
    ' Close Data Source
    '------------------
    lRtn = CloseTwainDS()
    If lRtn Then GoTo ErrPlace
    
    '--------------------------
    ' Close Data Source Manager
    '--------------------------
    lRtn = CloseTwainDSM()
    If lRtn Then GoTo ErrPlace
    blTwainOpen = False
    
    '----------------------------------
    ' Save DIB handle into the BMP file
    '----------------------------------
    lRtn = SaveDIBToFile(lhDIB, sBMPFileName)
    If lRtn Then GoTo ErrPlace

    TransferWithoutUI = 0
    Exit Function

ErrPlace:
    If lhDIB Then lRtn = GlobalFree(lhDIB)
    If blTwainOpen Then lRtn = CloseTwainDS(): lRtn = CloseTwainDSM()
    TransferWithoutUI = 1
End Function

Public Function TransferWithUI(ByVal sBMPFileName As String) As Long
        
    '-------------------------------------------------------------------
    ' Function transfers one image from Twain data source using the data
    '   source user interface to set image attributes.
    '
    ' Input values
    '   - sBMPFileName (String) - the file name of the saved image
    '
    ' Function returns 0 if OK, 1 if an error occurs
    '-------------------------------------------------------------
    
    Dim lRtn As Long
    Dim blTwainOpen As Boolean
    Dim lhDIB As Long
    
    On Local Error GoTo ErrPlace

    '-------------------------------
    ' Open Twain Data Source Manager
    '-------------------------------
    lRtn = OpenTwainDSM()
    If lRtn Then GoTo ErrPlace
    blTwainOpen = True

    '-----------------------
    ' Open Twain Data Source
    '-----------------------
    lRtn = OpenTwainDS()
    If lRtn Then GoTo ErrPlace

    '----------------------------------------------------
    ' TRANSFER the image with UI enabled.
    '   If successful, lhDIB is filled with handle to DIB
    '----------------------------------------------------
    lRtn = TwainTransfer(True, lhDIB)
    If lRtn Then GoTo ErrPlace

    '------------------
    ' Close Data Source
    '------------------
    lRtn = CloseTwainDS()
    If lRtn Then GoTo ErrPlace
    
    '--------------------------
    ' Close Data Source Manager
    '--------------------------
    lRtn = CloseTwainDSM()
    If lRtn Then GoTo ErrPlace
    blTwainOpen = False
    
    '----------------------------------
    ' Save DIB handle into the BMP file
    '----------------------------------
    lRtn = SaveDIBToFile(lhDIB, sBMPFileName)
    If lRtn Then GoTo ErrPlace

    TransferWithUI = 0
    Exit Function

ErrPlace:
    If lhDIB Then lRtn = GlobalFree(lhDIB)
    If blTwainOpen Then lRtn = CloseTwainDS(): lRtn = CloseTwainDSM()
    TransferWithUI = 1
End Function

Public Function PopupSelectSourceDialog() As Long
    
    '------------------------------------------------------------------
    ' Function shows the Twain dialog for selecting default data source
    '
    ' Function returns 0 if OK, 1 if an error occurs
    '------------------------------------------------------------------
    
    Dim iRtn As Integer
    Dim lRtn As Long
    
    On Local Error GoTo ErrPlace
    
    '-------------------------------
    ' Open Twain Data Source Manager
    '-------------------------------
    lRtn = OpenTwainDSM()
    If lRtn Then GoTo ErrPlace

    '----------------------------------------------------
    ' Popup "Select source" dialog
    '   DG_CONTROL, DAT_IDENTITY, MSG_USERSELECT
    '----------------------------------------------------
    iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_IDENTITY, _
                     MSG_USERSELECT, m_tSrcID)
    If iRtn <> TWRC_SUCCESS Then
        lRtn = CloseTwainDSM()
        GoTo ErrPlace
    End If
    
    '--------------------------------
    ' Close Twain Data Source Manager
    '--------------------------------
    lRtn = CloseTwainDSM()
    If lRtn Then GoTo ErrPlace
    
    PopupSelectSourceDialog = 0
    Exit Function
    
ErrPlace:
    PopupSelectSourceDialog = 1
End Function

Private Function OpenTwainDSM() As Long
    
    Dim iRtn As Integer
    
    On Local Error GoTo ErrPlace
    
    '----------------------------------------------------
    ' Create window that will receive all TWAIN messages
    ' Message loop can be found in TwainTransfer function
    '----------------------------------------------------
    m_lHndMsgWin = CreateWindowEx(0&, "#32770", "TWAIN_MSG_WINDOW", 0&, _
                                  10&, 10&, 150&, 50&, 0&, 0&, 0&, 0&)
    If m_lHndMsgWin = 0 Then GoTo ErrPlace
    
    '------------------------------------------------------------
    ' Introduce yourself to TWAIN - MajorNum, MinorNum, Language,
    ' Country, Manufacturer, ProductFamily, ProductName, etc.
    '------------------------------------------------------------
    Call ZeroMemory(VarPtr(m_tAppID), Len(m_tAppID))
    With m_tAppID
        .Version.MajorNum = 1
        .Version.Language = TWLG_CZECH
        .Version.Country = TWCY_CZECHOSLOVAKIA
        .ProtocolMajor = TWON_PROTOCOLMAJOR
        .ProtocolMinor = TWON_PROTOCOLMINOR
        .SupportedGroups1 = DG_CONTROL Or DG_IMAGE
    End With
    
    Call CopyMemory(VarPtr(m_tAppID.Manufacturer(1)), _
                    StrPtr(StrConv("LMik", vbFromUnicode)), _
                    Len("LMik"))
    Call CopyMemory(VarPtr(m_tAppID.ProductFamily(1)), _
                    StrPtr(StrConv("VB Module", vbFromUnicode)), _
                    Len("VB Module"))
    Call CopyMemory(VarPtr(m_tAppID.ProductName(1)), _
                    StrPtr(StrConv("VB Module for TWAIN", vbFromUnicode)), _
                    Len("VB Module for TWAIN"))
    
    '--------------------------------------
    ' Open Data Source Manager
    '   DG_CONTROL, DAT_PARENT, MSG_OPENDSM
    '--------------------------------------
    iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_PARENT, MSG_OPENDSM, _
                     m_lHndMsgWin)
    If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace
    
    OpenTwainDSM = 0
    Exit Function
    
ErrPlace:
    OpenTwainDSM = 1
End Function

Private Function OpenTwainDS() As Long

    Dim iRtn As Integer
    
    On Local Error GoTo ErrPlace
    
    '----------------------------------------------------------------------
    ' Open Data Source
    '   DG_CONTROL, DAT_IDENTITY, MSG_OPENDS
    '
    ' The default data source is opened. If you want user to select the new
    '   default one, call public function PopupSelectSourceDialog.
    '----------------------------------------------------------------------
    Call ZeroMemory(VarPtr(m_tSrcID), Len(m_tSrcID))
    iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_IDENTITY, MSG_OPENDS, _
                     m_tSrcID)
    If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace

    OpenTwainDS = 0
    Exit Function
    
ErrPlace:
    OpenTwainDS = 1
End Function

Private Function CloseTwainDS() As Long
    
    Dim iRtn As Integer
    
    On Local Error GoTo ErrPlace
    
    '----------------------------------------
    ' Close Data Source
    '   DG_CONTROL, DAT_IDENTITY, MSG_CLOSEDS
    '----------------------------------------
    iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_IDENTITY, _
                     MSG_CLOSEDS, m_tSrcID)
    If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace
    
    CloseTwainDS = 0
    Exit Function

ErrPlace:
    CloseTwainDS = 1
End Function

Private Function CloseTwainDSM() As Long
    
    Dim lRtn As Long
    Dim iRtn As Integer
    
    On Local Error GoTo ErrPlace

    '---------------------------------------
    ' Close Data Source Manager
    '   DG_CONTROL, DAT_PARENT, MSG_CLOSEDSM
    '---------------------------------------
    iRtn = DSM_Entry(m_tAppID, ByVal 0&, DG_CONTROL, DAT_PARENT, MSG_CLOSEDSM, _
                     m_lHndMsgWin)
    If iRtn <> TWRC_SUCCESS Then
        lRtn = DestroyWindow(m_lHndMsgWin)
        GoTo ErrPlace
    End If

    '---------------------------
    ' Destroy the message window
    '---------------------------
    lRtn = DestroyWindow(m_lHndMsgWin)
    If lRtn = 0 Then GoTo ErrPlace
    
    CloseTwainDSM = 0
    Exit Function

ErrPlace:
    CloseTwainDSM = 1
End Function

Private Function SetImageSize(ByRef sngLeft As Single, _
                              ByRef sngTop As Single, _
                              ByRef sngRight As Single, _
                              ByRef sngBottom As Single) As Long

    Dim tImageLayout As TW_IMAGELAYOUT
    Dim lRtn As Long
    Dim iRtn As Integer
    
    On Local Error GoTo ErrPlace
    
    '-------------------------------------------------------------------
    ' Set the size of the image - in default units
    '   DG_IMAGE, DAT_IMAGELAYOUT, MSG_SET
    '
    ' If you do not select any units the INCHES are selected as default.
    ' The values of Single type are converted into TWAIN TW_FIX32.
    '-------------------------------------------------------------------
    lRtn = FloatToFix32(sngLeft, tImageLayout.Frame.Left)
    If lRtn Then GoTo ErrPlace
    
    lRtn = FloatToFix32(sngTop, tImageLayout.Frame.Top)
    If lRtn Then GoTo ErrPlace
    
    lRtn = FloatToFix32(sngRight, tImageLayout.Frame.Right)
    If lRtn Then GoTo ErrPlace
    
    lRtn = FloatToFix32(sngBottom, tImageLayout.Frame.Bottom)
    If lRtn Then GoTo ErrPlace
    
    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_IMAGE, DAT_IMAGELAYOUT, MSG_SET, _
                     tImageLayout)
    If (iRtn <> TWRC_SUCCESS) And (iRtn <> TWRC_CHECKSTATUS) Then GoTo ErrPlace
    
    SetImageSize = 0
    Exit Function
    
ErrPlace:
    SetImageSize = 1
End Function

Public Function TwainTransfer(ByRef blShowUI As Boolean, _
                               ByRef lDIBHandle As Long) As Long
                               
    Dim tUI As TW_USERINTERFACE
    Dim tPending As TW_PENDINGXFERS
    Dim lhDIB As Long
    Dim tEvent As TW_EVENT
    Dim tMSG As MSG
    Dim lRtn As Long
    Dim iRtn As Integer
    
    On Local Error GoTo ErrPlace
    
    '---------------------------------------------
    ' Set tUI.ShowUI to 1 (show UI) or 0 (hide UI)
    '---------------------------------------------
    With tUI
        .ShowUI = IIf(blShowUI = True, 1, 0)
        .ModalUI = 1
        .hParent = m_lHndMsgWin
    End With
    
    '----------------------------------------------
    ' Enable Data Source User Interface
    '   DG_CONTROL, DAT_USERINTERFACE, MSG_ENABLEDS
    '----------------------------------------------
    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, _
                     MSG_ENABLEDS, tUI)
    If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace
    
    '-----------------------------------------------------------------
    ' Process events in the message loop
    '   DG_CONTROL, DAT_EVENT, MSG_PROCESSEVENT
    '
    ' There are two messages we are interested in in this message loop
    '   - MSG_XFERREADY - the data source is ready to transfer
    '   - MSG_CLOSEDSREQ - the data source requests to close itself
    '-----------------------------------------------------------------
    While GetMessage(tMSG, 0&, 0&, 0&)
        Call ZeroMemory(VarPtr(tEvent), Len(tEvent))
        tEvent.pEvent = VarPtr(tMSG)
        iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_EVENT, _
                         MSG_PROCESSEVENT, tEvent)
        Select Case tEvent.TWMessage
            Case MSG_XFERREADY
                GoTo MSGGET
            Case MSG_CLOSEDSREQ
                GoTo MSGDISABLEDS
        End Select
        lRtn = TranslateMessage(tMSG)
        lRtn = DispatchMessage(tMSG)
    Wend
    
MSGGET:
    '----------------------------------------------------
    ' Start transfer
    '   DG_IMAGE, DAT_IMAGENATIVEXFER, MSG_GET
    '
    ' If transfer is successful you get the handle to DIB
    '----------------------------------------------------
    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_IMAGE, DAT_IMAGENATIVEXFER, _
                     MSG_GET, lhDIB)
    If iRtn <> TWRC_XFERDONE Then
        iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_PENDINGXFERS, _
                         MSG_ENDXFER, tPending)
        iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, _
                         MSG_DISABLEDS, tUI)
        GoTo ErrPlace
    End If
    
    '--------------------------------------------
    ' End transfer
    '   DG_CONTROL, DAT_PENDINGXFERS, MSG_ENDXFER
    '--------------------------------------------
    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_PENDINGXFERS, _
                     MSG_ENDXFER, tPending)
    If iRtn <> TWRC_SUCCESS Then
        iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, _
                         MSG_DISABLEDS, tUI)
        GoTo ErrPlace
    End If
    
MSGDISABLEDS:
    '-----------------------------------------------
    ' Disable Data Source
    '   DG_CONTROL, DAT_USERINTERFACE, MSG_DISABLEDS
    '-----------------------------------------------
    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_USERINTERFACE, _
                     MSG_DISABLEDS, tUI)
    If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace

    lDIBHandle = lhDIB
    TwainTransfer = 0
    Exit Function
    
ErrPlace:
    If lhDIB Then lRtn = GlobalFree(lhDIB)
    lDIBHandle = 0
    TwainTransfer = 1
End Function

Private Function SaveDIBToFile(ByRef lhDIB As Long, _
                               ByRef sFileName As String) As Long
    
    '---------------------------------------------------------------------------
    ' Function saves the handle to DIB (device independent bitmap) into BMP file
    '---------------------------------------------------------------------------

    Dim tBFH As BITMAPFILEHEADER
    Dim tBIH As BITMAPINFOHEADER
    Dim tRGB As RGBQUAD
    Dim lpDIB As Long
    Dim lDIBSize As Long
    Dim bDIBits() As Byte
    Dim iFileNum As Integer
    Dim lRtn As Long
    
    On Local Error GoTo ErrPlace
    
    If sFileName = "" Then GoTo ErrPlace
    
    If Dir(sFileName, vbNormal Or vbHidden Or vbSystem) <> "" Then
        Call SetAttr(sFileName, vbNormal)
        Call Kill(sFileName)
    End If
    
    lpDIB = GlobalLock(lhDIB)
    If lpDIB = 0 Then GoTo ErrPlace
    
    Call CopyMemory(VarPtr(tBIH), lpDIB, Len(tBIH))
    
    lDIBSize = Len(tBIH) + (tBIH.biClrUsed * Len(tRGB)) + _
               (((tBIH.biWidth * tBIH.biBitCount + 31) \ 32) * 4 * tBIH.biHeight)
    ReDim bDIBits(1 To lDIBSize) As Byte
    Call CopyMemory(VarPtr(bDIBits(1)), lpDIB, lDIBSize)
    
    lRtn = GlobalUnlock(lhDIB)
    lRtn = GlobalFree(lhDIB)
    lhDIB = 0
    
    With tBFH
        .bfType = 19778     ' "BM"
        .bfSize = Len(tBFH) + lDIBSize
        .bfOffBits = Len(tBFH) + Len(tBIH) + (tBIH.biClrUsed * Len(tRGB))
    End With
    iFileNum = FreeFile
    Open sFileName For Binary As #iFileNum
        Put #iFileNum, , tBFH
        Put #iFileNum, , bDIBits()
    Close #iFileNum
    
    SaveDIBToFile = 0
    Exit Function
    
ErrPlace:
    lRtn = GlobalUnlock(lhDIB)
    lRtn = GlobalFree(lhDIB)
    lhDIB = 0
    SaveDIBToFile = 1
End Function

Private Function TwainSetOneValue(ByVal Cap As TWAIN_MDL_CAPABILITY, _
                                  ByVal ItemType As TWAIN_MDL_ITEMYPE, _
                                  ByRef Item As Variant) As Long

    '-----------------------------------------------------------------------
    ' There are four types of containers that TWAIN defines for capabilities
    ' (TW_ONEVALUE, TW_ARRAY, TW_RANGE and TW_ENUMERATION)
    ' This module deals with one of them only - TW_ONEVALUE (single value)
    ' To set some capability you have to fill TW_ONEVALUE fields and use
    '   the triplet DG_CONTROL DAT_CAPABILITY MSG_SET
    ' The macros that convert some data types are used here as well
    '-----------------------------------------------------------------------
    On Local Error GoTo ErrPlace
    
    Dim tCapability As TW_CAPABILITY
    Dim tOneValue As TW_ONEVALUE
    Dim lhOneValue As Long
    Dim lpOneValue As Long
    Dim lRtn As Long
    Dim iRtn As Integer
    Dim tFix32 As TW_FIX32
    Dim iTmp As Integer

    tCapability.ConType = TWON_ONEVALUE
    tCapability.Cap = Cap
    
    tOneValue.ItemType = ItemType
    
    Select Case ItemType
        Case INT16
            tOneValue.Item1 = CInt(Item)
        Case UINT16, BOOL
            If ToUnsignedShort(CLng(Item), iTmp) Then GoTo ErrPlace
            Call CopyMemory(VarPtr(tOneValue.Item1), VarPtr(iTmp), 2&)
        Case FIX32
            If FloatToFix32(CSng(Item), tFix32) Then GoTo ErrPlace
            Call CopyMemory(VarPtr(tOneValue.Item1), VarPtr(tFix32), 4&)
    End Select

    lhOneValue = GlobalAlloc(GHND, Len(tOneValue))
    lpOneValue = GlobalLock(lhOneValue)
    Call CopyMemory(lpOneValue, VarPtr(tOneValue), Len(tOneValue))
    lRtn = GlobalUnlock(lhOneValue)
    tCapability.hContainer = lhOneValue

    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_SET, _
                     tCapability)
    If iRtn <> TWRC_SUCCESS Then
        lRtn = GlobalFree(lhOneValue)
        GoTo ErrPlace
    End If
    lRtn = GlobalFree(lhOneValue)

    TwainSetOneValue = 0
    Exit Function

ErrPlace:
    TwainSetOneValue = 1
End Function

Private Function TwainGetOneValue(ByVal Cap As TWAIN_MDL_CAPABILITY, _
                                  ByRef Item As Variant) As Long

    '-----------------------------------------------------------------------
    ' There are four types of containers that TWAIN defines for capabilities
    ' (TW_ONEVALUE, TW_ARRAY, TW_RANGE and TW_ENUMERATION)
    ' This module deals with one of them only - TW_ONEVALUE (single value)
    ' To get some capability you have to fill TW_ONEVALUE fields and use
    '   the triplet DG_CONTROL DAT_CAPABILITY MSG_GET
    ' The macros that convert some data types are used here as well
    '-----------------------------------------------------------------------
    
    On Local Error GoTo ErrPlace
    
    Dim tCapability As TW_CAPABILITY
    Dim tOneValue As TW_ONEVALUE
    Dim tFix32 As TW_FIX32
    Dim lpOneValue As Long
    Dim lRtn As Long
    Dim iRtn As Integer

    tCapability.ConType = TWON_ONEVALUE
    tCapability.Cap = Cap
    
    iRtn = DSM_Entry(m_tAppID, m_tSrcID, DG_CONTROL, DAT_CAPABILITY, MSG_GET, _
                     tCapability)
    If iRtn <> TWRC_SUCCESS Then GoTo ErrPlace
    
    lpOneValue = GlobalLock(tCapability.hContainer)
    Call CopyMemory(VarPtr(tOneValue), lpOneValue, Len(tOneValue))
    lRtn = GlobalUnlock(tCapability.hContainer)
    lRtn = GlobalFree(tCapability.hContainer)

    Select Case tOneValue.ItemType
        Case INT16
            Item = tOneValue.Item1
        Case UINT16, BOOL
            Item = FromUnsignedShort(tOneValue.Item1)
        Case FIX32
            Call CopyMemory(VarPtr(tFix32), VarPtr(tOneValue.Item1), 4&)
            Item = Fix32ToFloat(tFix32)
    End Select
    
    TwainGetOneValue = 0
    Exit Function

ErrPlace:
    TwainGetOneValue = 1
End Function

Private Function ToUnsignedShort(ByRef lSrc As Long, _
                                 ByRef iDst As Integer) As Long
    
    '------------------------------------------------------------------------
    ' Sets number ranging from 0 to 65535 into 2-byte VB Integer
    ' (useful for communicating with other dll that uses unsigned data types)
    '
    ' Function returns 0 is OK, 1 if an error occurs
    '------------------------------------------------------------------------
    
    On Local Error GoTo ErrPlace
    
    If (lSrc < 0) Or (lSrc > 65535) Then GoTo ErrPlace
    
    Call CopyMemory(VarPtr(iDst), VarPtr(lSrc), 2&)
    
    ' Another way
    'iDst = IIf(lSrc > 32767, lSrc - 65536, lSrc)
    
    ToUnsignedShort = 0
    Exit Function
    
ErrPlace:
    ToUnsignedShort = 1
End Function

Private Function FromUnsignedShort(ByRef iSrc As Integer) As Long

    '------------------------------------------------------------------------
    ' Gets the 2-byte unsigned number from VB Integer data type
    ' (useful for communicating with other dll that uses unsigned data types)
    '
    ' Function returns unsigned 2-byte value (in VB Long type)
    '------------------------------------------------------------------------
    
    Dim lTmp As Long
    
    Call CopyMemory(VarPtr(lTmp), VarPtr(iSrc), 2&)
    
    ' Another way
    'lTmp = IIf(iSrc < 0, iSrc + 65536, iSrc)
    
    FromUnsignedShort = lTmp

End Function

Private Function ToUnsignedLong(ByRef sngSrc As Single, _
                                ByRef lDst As Long) As Long

    '------------------------------------------------------------------------
    ' Sets number ranging from 0 to 4294967295 into 4-byte VB Long
    ' (useful for communicating with other dll that uses unsigned data types)
    '
    ' Function returns 0 is OK, 1 if an error occurs
    '------------------------------------------------------------------------

    On Local Error GoTo ErrPlace
    
    If (sngSrc < 0) Or (sngSrc > 4294967295#) Then GoTo ErrPlace
    
    lDst = IIf(sngSrc > 2147483647, sngSrc - 4294967296#, sngSrc)
    
    ToUnsignedLong = 0
    Exit Function
    
ErrPlace:
    ToUnsignedLong = 1
End Function

Private Function FromUnsignedLong(ByRef lSrc As Long) As Single

    '------------------------------------------------------------------------
    ' Gets the 4-byte unsigned number from VB Long data type
    ' (useful for communicating with other dll that uses unsigned data types)
    '
    ' Function returns unsigned 4-byte value (in VB Single type)
    '------------------------------------------------------------------------

    Dim sngTmp As Single
    
    sngTmp = IIf(lSrc < 0, lSrc + 4294967296#, lSrc)
    FromUnsignedLong = sngTmp

End Function

Private Function Fix32ToFloat(ByRef tFix32 As TW_FIX32) As Single
        
    '----------------------------------------------------------------
    ' Converts TWAIN TW_FIX32 data structure into VB Single data type
    ' (needed for communicating with TWAIN)
    '
    ' Function returns floating-point number in VB Single data type
    '----------------------------------------------------------------
        
    Dim sngTmp As Single
    
    sngTmp = tFix32.Whole + CSng(FromUnsignedShort(tFix32.Frac) / 65536)
    Fix32ToFloat = sngTmp

End Function

Private Function FloatToFix32(ByRef sngSrc As Single, _
                              ByRef tFix32 As TW_FIX32) As Long
    
    '----------------------------------------------------------------
    ' Converts VB Single data type into TWAIN TW_FIX32 data structure
    ' (needed for communicating with TWAIN)
    '
    ' Function returns 0 is OK, 1 if an error occurs
    '----------------------------------------------------------------
    
    On Local Error GoTo ErrPlace
    
    tFix32.Whole = CInt(Fix(sngSrc))
    Call ToUnsignedShort(CLng(sngSrc * 65536) And 65535, tFix32.Frac)
    FloatToFix32 = 0
    Exit Function

ErrPlace:
    FloatToFix32 = 1
End Function

.

جعفر

  • Like 1
رابط هذا التعليق
شارك

استاذي الفاضل الاستاذ القدير جعفر السلام عليكم  ورحمة الله وبركاته

عندما رأيت هذا الكود القاهر انتابتني الرعدة والخوف واصبحت لا اعرف اين اذهب وكيف لي العوم في هذا البحر الكبير فبقيت متحيرا اين السبيل 

استاذي الفاضل ربي يحميك من كل شر يارب فضلا لا امرا اين اضع هذا الكود القاهر وكيف التعامل معه يرجى مساعدتي في استخدامه 

واكون ممنون اليك وانا شاكرا تعاونك معي والله الموفق

 

تم تعديل بواسطه حربي العنزي
رابط هذا التعليق
شارك

20 دقائق مضت, حربي العنزي said:

اين اضع هذا الكود القاهر وكيف التعامل معه

بس!! غالي والطلب رخيص:smile:

 

احفظ الكود في وحدة نمطية ،

ثم استخدم طريقة المناداة ، 1 او 2 او 3 من نموذجك على حدث ضغط الزر مثلا ، والسلام:smile:

 

جعفر

رابط هذا التعليق
شارك

استاذي الفاضل الاستاذ القدير جعفر السلام عليكم  ورحمة الله وبركاته

جزاك الله كل الخير وربي يحميك من كل سوء يارب 

عملت ماطلبت مني ولكن كود الاستدعاء رقم 3 لم يعمل معي الذي هو  

وربي يخليك يالطيب

3.
TransferWithoutUI(300, rgb, 0, 0, 8.3, 11.7,"D:\jj2.bmp")
رابط هذا التعليق
شارك

21 دقائق مضت, حربي العنزي said:

ولكن كود الاستدعاء رقم 3 لم يعمل معي

شو يعني ؟

هل طلع لك خطأ ، هل توقف عند خط معين ؟

 

وقبل ان تختار الخط رقم3 ، هل جربت الرقم 1 و 2 ؟

 

جعفر

رابط هذا التعليق
شارك

استاذي الفاضل الاستاذ القدير جعفر

نعم جربت بعد ان وقفت الكود رقم 3 اشتغل عندي وظهر لي اختار الاسكنر وعند اختيار الاسكنر والضغط على موافق تظهر رسالة الخطأ علامة التعجب الحمراء

رابط هذا التعليق
شارك

استاذي الفاضل الاستاذ القدير جعفر ربي يخليك يالطيب

انا اسف الرسالة تقول ان الاسكنر غير مثبت راح اثبت الاسكنر واعطيك النتيجة 

وربي يحميك من كل شر يارب

 

رابط هذا التعليق
شارك

1.
PopupSelectSourceDialog

2.
TransferWithUI("d:\j.bmp")

3.
TransferWithoutUI(300, rgb, 0, 0, 8.3, 11.7,"D:\jj2.bmp")

لا تستعملهم كلهم مع بعض ، وانما:

1. اختار الاسكانر ،

ثم اختار 2 او 3.

 

14 دقائق مضت, حربي العنزي said:

وعند اختيار الاسكنر والضغط على موافق تظهر رسالة الخطأ علامة التعجب الحمراء

اريد صورة منها ، وكذلك صورة من صفحة الكود والسطر ذو اللون الاصفر.

 

في اعتقادي انه بعد ان اضفنا الدوال اعلاه الى برنامجك ، بعضها كان موجودة في الوحدة النمطية القديمة ، لذا يجب ان نوقفها !!

 

جعفر

7 دقائق مضت, حربي العنزي said:

انا اسف الرسالة تقول ان الاسكنر غير مثبت راح اثبت الاسكنر واعطيك النتيجة 

حلللللوة ، وحنا قاعدين نضرب اخماس في اسداس لمعرفة المشكلة:blink:

 

جعفر

  • Like 2
رابط هذا التعليق
شارك

تفضل يا سيدي:

Private Sub cmdScan_Click()
Dim Ret As Long, PictureFile As String

    PictureFile = mypathofdb() & "\PIC\" & "pic" & Me.ImageID & ".jpg"
    'Ret = TWAIN_AcquireToFilename(Me.hwnd, PictureFile)
    Ret = TransferWithoutUI(300, RGB, 0, 0, 8.3, 11.7, PictureFile)

    If Ret = 0 Then

        Me.ImagePath = PictureFile
        Me![ImageFrame].Picture = Me![ImagePath]

    Else
        MsgBox "فشلت عملية المسح الضوئي", vbCritical, "تحذير"
    End If
    
End Sub

Private Sub cmdSelect_Click()
    'TWAIN_SelectImageSource (Me.hwnd)
    PopupSelectSourceDialog
End Sub

.

جعفر

za-EMP.zip

  • Like 4
رابط هذا التعليق
شارك

استاذي الفاضل الاستاذ القدير جعفر ربي يخليك يالطيب

الله لايحرمنا من شخصك الكريم سائلين الله جل وعلا ان يمن عليك وعلى عائلتك الكريمة بالصحة والعافية والستر في الدنيا والاخرة يارب

نعم هذا هو المطلوب 

بوركت يالطيب وجزاك الله كل الخير 

رابط هذا التعليق
شارك

استاذي الفاضل الاستاذ القدير جعفر ربي يخليك يالطيب وجزاك الله كل الخير 

النتيجة نعم اشتغل على الاجهزة القديمة والجديدة بكل دقة وبشكل جيد جدا والفضل لله اولا ولك ثانيا استاذنا القدير ربي يحفظ يارب

 

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information